diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl
index 8a1d4424b2..f2e646b03d 100644
--- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl
+++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl
@@ -31,6 +31,7 @@ constraints.
        racket/contract/private/guts
        racket/contract/private/prop
        racket/contract/private/blame
+       racket/contract/collapsible
        racket/contract/private/ds
        racket/contract/private/opt
        racket/contract/private/basic-opters
@@ -2012,14 +2013,15 @@ The @racket[define-struct/contract] form only allows a subset of the
            pos-blame-party
            source-loc
            name-for-blame
-           no-context)
+           context-limit)
          #:grammar ([pos-blame-party (code:line)
                                      (code:line #:pos-source pos-source-expr)]
                     [source-loc (code:line)
                                 (code:line #:srcloc srcloc-expr)]
-                    [name-for-blame (code:line)
-                     (code:line #:name-for-blame blame-id)]
-                    [name-for-blame (code:line)
+                    [name-for-blame
+                     (code:line)
+                     #:name-for-blame blame-id]
+                    [context-limit (code:line)
                      (code:line #:context-limit limit-expr)])]{
   Defines @racket[id] to be @racket[orig-id], but with the contract
   @racket[contract-expr].
@@ -2133,6 +2135,10 @@ accepted by the third argument to @racket[datum->syntax].
            late-neg-proj
            (or/c #f (-> blame? (-> any/c any/c any/c)))
            #f]
+          [#:collapsible-late-neg-projection
+           collapsible-late-neg-proj
+           (or/c #f (-> blame? (values (-> any/c any/c any/c) collapsible-contract?)))
+           #f]
           [#:val-first-projection
            val-first-proj
            (or/c #f (-> blame? (-> any/c (-> any/c any/c))))
@@ -2161,6 +2167,10 @@ accepted by the third argument to @racket[datum->syntax].
            late-neg-proj
            (or/c #f (-> blame? (-> any/c any/c any/c)))
            #f]
+          [#:collapsible-late-neg-projection
+           collapsible-late-neg-proj
+           (or/c #f (-> blame? (values (-> any/c any/c any/c) collapsible-contract?)))
+           #f]
           [#:val-first-projection 
            val-first-proj
            (or/c #f (-> blame? (-> any/c (-> any/c any/c))))
@@ -2189,6 +2199,10 @@ accepted by the third argument to @racket[datum->syntax].
            late-neg-proj
            (or/c #f (-> blame? (-> any/c any/c any/c)))
            #f]
+          [#:collapsible-late-neg-projection
+           collapsible-late-neg-proj
+           (or/c #f (-> blame? (values (-> any/c any/c any/c) collapsible-contract?)))
+           #f]
           [#:val-first-projection 
            val-first-proj
            (or/c #f (-> blame? (-> any/c (-> any/c any/c))))
@@ -2213,7 +2227,7 @@ accepted by the third argument to @racket[datum->syntax].
 )]{
 
 These functions build simple higher-order contracts, @tech{chaperone contracts},
-and @tech{flat contracts}, respectively.  They both take the same set of three
+and @tech{flat contracts}, respectively.  They all take the same set of three
 optional arguments: a name, a first-order predicate, and a blame-tracking projection.
 For @racket[make-flat-contract], see also @racket[flat-contract-with-explanation].
 
@@ -2242,6 +2256,14 @@ The @racket[late-neg-proj] argument defines the behavior of applying
  contract), or signal a contract violation using @racket[raise-blame-error].
  The default is @racket[#f].
  
+ The @racket[collapsible-late-neg-proj] argument takes the place of the
+ @racket[late-neg-proj] argument for contracts that support collapsing.
+ If it is supplied, this argument accepts a @tech{blame object} that is
+ missing one party. It must return two values. The first value must be
+ a function that accepts both the value that is getting the contract and
+ the name of the missing blame party, in that order. The second value should
+ be a collapsible representation of the contract.
+ 
 The projection @racket[proj] and @racket[val-first-proj] are older mechanisms for
  defining the behavior of applying the contract.  The @racket[proj] argument
 is a curried function of two arguments: the first application accepts a blame
@@ -2322,7 +2344,8 @@ to determine if this is a contract that accepts only @racket[list?] values.
 ]
 
 @history[#:changed "6.0.1.13" @list{Added the @racket[#:list-contract?] argument.}
-         #:changed "6.90.0.30" @list{Added the @racket[#:equivalent] argument.}]
+         #:changed "6.90.0.30" @list{Added the @racket[#:equivalent] argument.}
+         #:changed "7.1.0.10" @list{Added the @racket[#:collapsible-late-neg-projection] argument.}]
 }
 
 @defproc[(build-compound-type-name [c/s any/c] ...) any]{
@@ -2562,7 +2585,6 @@ when @racket[context] is @racket[#f].
   an error message, if @racket[blame] is passed to @racket[raise-blame-error].
 }
 
-
 @deftogether[(
 @defproc[(blame-positive [b blame?]) any/c]
 @defproc[(blame-negative [b blame?]) any/c]
@@ -2741,6 +2763,10 @@ returns @racket[#f] but @racket[value-blame] returns @racket[#f].
            late-neg-proj
            (or/c #f (-> contract? (-> blame? (-> any/c any/c any/c))))
            #f]
+          [#:collapsible-late-neg-projection
+           collapsible-late-neg-proj
+           (or/c #f (-> contract? (-> blame? (values (-> any/c any/c any/c) collapsible-contract?))))
+           #f]
           [#:val-first-projection 
            val-first-proj
            (or/c #f (-> contract? blame? (-> any/c (-> any/c any/c))))
@@ -2787,6 +2813,10 @@ returns @racket[#f] but @racket[value-blame] returns @racket[#f].
            late-neg-proj
            (or/c #f (-> contract? (-> blame? (-> any/c any/c any/c))))
            #f]
+          [#:collapsible-late-neg-projection
+           collapsible-late-neg-proj
+           (or/c #f (-> contract? (-> blame? (values (-> any/c any/c any/c) collapsible-contract?))))
+           #f]
           [#:val-first-projection 
            val-first-proj
            (or/c #f (-> contract? blame? (-> any/c (-> any/c any/c))))
@@ -2843,6 +2873,10 @@ returns @racket[#f] but @racket[value-blame] returns @racket[#f].
            late-neg-proj
            (or/c #f (-> contract? (-> blame? (-> any/c any/c any/c))))
            #f]
+          [#:collapsible-late-neg-projection
+           collapsible-late-neg-proj
+           (or/c #f (-> contract? (-> blame? (values (-> any/c any/c any/c) collapsible-contract?))))
+           #f]
           [#:val-first-projection 
            val-first-proj
            (or/c #f (-> contract? blame? (-> any/c (-> any/c any/c))))
@@ -2901,6 +2935,10 @@ a contract.  It is specified in terms of seven properties:
    defining the behavior of the contract (The @racket[get-projection]
    and @racket[val-first-proj] arguments also specify the projection,
    but using a different signature. They are here for backwards compatibility.);}
+  @item{@racket[collapsible-late-neg-proj], similar to @racket[late-neg-proj]
+   which produces a blame-tracking projection defining the behavior of the
+   contract, this function additionally specifies the collapsible behavior
+   of the contract;}
   @item{@racket[stronger], a predicate that determines whether this
    contract (passed in the first argument) is stronger than some other
    contract (passed in the second argument) and whose default always
@@ -2922,8 +2960,9 @@ a contract.  It is specified in terms of seven properties:
    to determine if this contract accepts only @racket[list?]s.}
 ]
 
-At least one of the @racket[late-neg-proj], @racket[get-projection],
-@racket[val-first-proj], or @racket[get-first-order] must be non-@racket[#f].
+At least one of the @racket[late-neg-proj], @racket[collapsible-late-neg-proj],
+@racket[get-projection], @racket[val-first-proj], or @racket[get-first-order]
+must be non-@racket[#f].
 
 These accessors are passed as (optional) keyword arguments to
 @racket[build-contract-property], and are applied to instances of the
@@ -2952,7 +2991,8 @@ arguments as @racket[build-contract-property].  The differences are:
          #:changed "6.1.1.4"
          @list{Allow @racket[generate] to return @racket[contract-random-generate-fail].}
          #:changed "6.90.0.30"
-         @list{Added the @racket[#:equivalent] argument.}]
+         @list{Added the @racket[#:equivalent] argument.}
+         #:changed "7.1.0.10" @list{Added the @racket[#:collapsible-late-neg-projection] argument.}]
 }
 
 @deftogether[(
@@ -3356,6 +3396,8 @@ and fix at some point, but have no concrete plans currently.
 Key used by continuation marks that are present during contract checking.
 The value of these marks are the @|blame-objects| that correspond to the contract
 currently being checked.
+
+@history[#:added "6.4.0.4"]
 }
 
 @defproc[(contract-custom-write-property-proc [c contract?] 
@@ -3462,6 +3504,160 @@ add contracts to libraries that @racketmodname[racket/contract]
 uses to implement some of the more sophisticated
 parts of the contract system.
 
+@; ------------------------------------------------------------------------
+
+@section[#:tag "collapsible"]{Collapsible Contracts}
+@defmodule*/no-declare[(racket/contract/collapsible)]
+@declare-exporting-ctc[racket/contract/collapsible]
+@history[#:added "7.1.0.10"]
+
+@deftech{Collapsible contracts} are an optimization in the contract system designed
+to avoid a particular pathological build up of contract wrappers on higher-order
+values. The @racket[vectorof], @racket[vector/c], and @racket[->] contract
+combinators support collapsing for vector contracts and function contracts for
+functions returning a single value.
+
+@bold{Warning}: the features described in this section are experimental
+and may not be sufficient to implement new collapsible contracts. Implementing
+new collapsible contracts requires the use of unsafe chaperones and impersonators
+which are only supported for vector and procedure values. This documentation exists
+primarily to allow future maintenance of the @racket[racket/contract/collapsible] library/
+
+@defproc[(get/build-collapsible-late-neg-projection [c contract?])
+         (-> blame? (values (-> any/c any/c any/c) collapsible-contract?))]{
+ Returns the @racket[_collapsible-late-neg] projection for @racket[c].
+
+ If @racket[c] does not have a @racket[_collapsible-late-neg] projection,
+ then this function uses the original projection for it and constructs a leaf
+ as its collapsible representation.
+}
+
+@defthing[collapsible-contract-continuation-mark-key continuation-mark-key?]{
+Key used by continuation marks that are present during collapsible contract checking.
+The value of these marks are @racket[#t] if the current contract is collapsible.
+}
+
+@defform[(with-collapsible-contract-continuation-mark body ...)]{
+Inserts a continuation mark that informs the contract profiler that the current contract
+is collapsible.
+}
+
+@defthing[prop:collapsible-contract struct-type-property?]{
+ Structures implementing this property are usable as collapsible contracts. The value
+ associated with this property should be constructed by calling
+ @racket[build-collapsible-contract-property].
+}
+
+@defproc[(collapsible-contract? [v any/c]) boolean?]{
+A predicate recognizing structures with the @racket[prop:collapsible-contract] property.}
+
+@defproc[(merge [new-cc collapsible-contract?]
+                [new-neg any/c]
+                [old-cc collapsible-contract?]
+                [old-neg any/c])
+         collapsible-contract?]{
+ Combine two collapsible contracts into a single collapsible contract.
+ The @racket[new-neg] and @racket[old-neg] arguments are expected to be
+ blame parties similar to those passed to a @tech{late neg projection}.
+}
+
+@defproc[(collapsible-guard [cc collapsible-contract?]
+                            [val any/c]
+                            [neg-party any/c])
+         any/c]{
+ Similar to a @tech{late neg projection}, this function guards the value @racket[val]
+ with the collapsible contract @racket[cc].
+}
+
+@defproc[(collapsible-contract-property? [v any/c]) boolean?]{
+ This predicate indicates that a value can be used as the property for
+ @racket[prop:collapsible-contract].
+}
+
+@defproc[(build-collapsible-contract-property
+          [#:try-merge try-merge
+           (or/c #f
+                 (-> collapsible-contract?
+                     any/c
+                     collapsible-contract?
+                     any/c
+                     (or/c #f collapsible-contract?)))
+           #f]
+          [#:collapsible-guard collapsible-guard
+           (-> collapsible-contract? any/c any/c any/c)
+           (λ (cc v neg)
+             (error
+              "internal error: contract does not support `collapsible-guard`" ctc))])
+         collapsible-contract-property?]{
+ Constructs a @deftech{collapsible contract property} from a merging function and a guard.
+ The @racket[try-merge] argument is similar to @racket[merge], but may return @racket[#f] instead
+ of a collapsible contract and may be specialized to a particular collapsible contract.
+ The @racket[collapsible-guard] argument should be specialized to the particular collapsible
+ contract being implemented.
+}
+
+@defstruct*[collapsible-ho/c
+            ([latest-blame blame?]
+             [missing-party any/c]
+             [latest-ctc contract?])]{
+ A common parent structure for collapsible contracts for higher-order values.
+ The @racket[latest-blame] field holds the blame object for the most recent
+ contract attached. Similarly, the @racket[missing-party] filed holds the latest
+ missing party passed to the contract. The @racket[latest-contract] field stores
+ the most recent contract attached to the value.
+}
+
+@defstruct*[collapsible-leaf/c
+            ([proj-list (listof (-> any/c any/c any/c))]
+             [contract-list (listof contract?)]
+             [blame-list (listof blame?)]
+             [missing-party-list (listof any/c)])]{
+ A structure representing the leaf nodes of a collapsible contract. The @racket[proj-list]
+ field holds a list of partially applied @tech{late neg projections}. The @racket[contract-list],
+ @racket[blame-list], and @racket[missing-party-list] fields hold a list of contracts,
+ blame objects, and blame missing parties respectively.
+}
+
+@deftogether[(@defthing[impersonator-prop:collapsible impersonator-property?]
+              @defproc[(has-impersonator-prop:collapsible? [v any/c]) boolean?]
+              @defproc[(get-impersonator-prop:collapsible [v any/c]) collapsible-property?])]{
+ An impersonator property (and its accessors) that should be attached to chaperoned or impersonated
+ values that are guarded with a collapsible contract.
+}
+
+@defstruct*[collapsible-property ([c-c collapsible-contract?]
+                                  [neg-party any/c]
+                                  [ref (or/c #f impersonator?)])]{
+ The parent struct of properties that should be attached to chaperones or impersonators
+ of values protected with a collapsible contract. The @racket[c-c] field stores the collapsible
+ contract that is or will in the future be attached to the the value. The @racket[neg-party] field
+ stores the latest missing blame party passed to the contract on the value. The @racket[ref] field
+ is mutable and stores a reference to the chaperone or impersonator to which this property is
+ attached. This is necessary to determine whether an unknown chaperone has been attached to a value
+ after it has been protected by a collapsible contract.
+}
+@defstruct*[(collapsible-count-property collapsible-property)
+            ([count natural-number/c]
+             [prev (or/c collapsible-count-property? any/c)])]{
+ This property is associated with the @racket[impersonator-prop:collapsible] property before
+ the value completely enters the collapsible mode. These properties keep track of the number of
+ contracts on a value in the @racket[_count] field, and hold a reference to the previous
+ @deftech{count property} in the @racket[prev] field or the original value without a contract. This
+ allows the contract system to traverse the chain of attached contracts and merge them into a single
+ collapsible contract to protect the original value.
+}
+@defstruct*[(collapsible-wrapper-property collapsible-property)
+            ([checking-wrapper impersonator?])]{
+ This property is used when a value is guarded by a collapsible contract. The
+ @racket[checking-wrapper] field holds a chaperone or impersonator that dispatches to the
+ collapsible contract stored in this property to perform any necessary contract checks. When
+ the value receives another contract and merging happens, the checking wrapper will remain the
+ same even though the specific collapsible contract attached to the value may change.
+}
+
+@; ------------------------------------------------------------------------
+
+
 @section{Legacy Contracts}
 
 @defproc[(make-proj-contract [name any/c]
diff --git a/pkgs/racket-doc/scribblings/reference/mz.rkt b/pkgs/racket-doc/scribblings/reference/mz.rkt
index 0ba6e1fddd..7c6531d55e 100644
--- a/pkgs/racket-doc/scribblings/reference/mz.rkt
+++ b/pkgs/racket-doc/scribblings/reference/mz.rkt
@@ -5,14 +5,18 @@
          scribble/examples
          scribble/decode
          racket/contract
+         racket/contract/collapsible
          "../icons.rkt")
 
 (provide (all-from-out scribble/manual)
          (all-from-out scribble/examples)
-         (all-from-out racket/contract))
+         (all-from-out racket/contract)
+         (all-from-out racket/contract/collapsible))
 
 (require (for-label racket))
 (provide (for-label (all-from-out racket)))
+(require (for-label racket/contract/collapsible))
+(provide (for-label (all-from-out racket/contract/collapsible)))
 
 (provide mz-examples)
 (define mz-eval (make-base-eval))
diff --git a/pkgs/racket-test/tests/racket/contract/arrow-d.rkt b/pkgs/racket-test/tests/racket/contract/arrow-d.rkt
index ec265ffe51..0291889500 100644
--- a/pkgs/racket-test/tests/racket/contract/arrow-d.rkt
+++ b/pkgs/racket-test/tests/racket/contract/arrow-d.rkt
@@ -800,7 +800,21 @@
                  'neg))
       x)
    '(body ctc)
-   '(body ctc ctc)) ; result if contract is applied twice
+   do-not-double-wrap)
+
+  (test/spec-passed/result
+   '->d-underscore2-double-wrap
+   '(let ([x '()])
+      ((contract (->d () () [_ (begin (set! x (cons 'ctc x)) any/c)])
+                 (contract
+                  (->d () () [_ (begin (set! x (cons 'ctc x)) any/c)])
+                  (λ () (set! x (cons 'body x)))
+                  'pos 'neg)
+                 'pos
+                 'neg))
+      x)
+   '(body ctc ctc)
+   do-not-double-wrap)
   
   (test/spec-passed/result
    '->d-underscore3
@@ -811,7 +825,21 @@
                  'neg))
       x)
    '(ctc body)
-   '(ctc ctc body)) ; result if contract is applied twice
+   do-not-double-wrap)
+
+  (test/spec-passed/result
+   '->d-underscore3-double-wrap
+   '(let ([x '()])
+      ((contract (->d () () [res (begin (set! x (cons 'ctc x)) any/c)])
+                 (contract
+                  (->d () () [res (begin (set! x (cons 'ctc x)) any/c)])
+                  (λ () (set! x (cons 'body x)))
+                  'pos 'neg)
+                 'pos
+                 'neg))
+      x)
+   '(ctc ctc body)
+   do-not-double-wrap)
   
   (test/spec-passed/result
    '->d-underscore4
diff --git a/pkgs/racket-test/tests/racket/contract/arrow-i.rkt b/pkgs/racket-test/tests/racket/contract/arrow-i.rkt
index e403b3ff8e..5ac9f699a3 100644
--- a/pkgs/racket-test/tests/racket/contract/arrow-i.rkt
+++ b/pkgs/racket-test/tests/racket/contract/arrow-i.rkt
@@ -750,18 +750,48 @@
        b)
       (unbox b))
    '(5 4 3 2 1)
-   '(5 4 5 4 3 2 1 2 1)) ; result if contract is applied twice
+   do-not-double-wrap)
   
   (test/spec-passed/result
-   '->i44
-   '((contract (->i ([x () any/c])
-                    [y any/c]
-                    #:post (x) x)
-               (lambda (x) x)
-               'pos
-               'neg)
-     #t)
-   '#t)
+   '->i43-double-wrap
+   '(let ([b (box '())])
+      ((contract (->i ([i (box/c (listof integer?))])
+                      (values [_ (i)
+                                 (begin
+                                   (set-box! i (cons 1 (unbox i)))
+                                   (λ (x)
+                                     (set-box! i (cons 4 (unbox i)))
+                                     #t))]
+                              [_ (i)
+                                 (begin
+                                   (set-box! i (cons 2 (unbox i)))
+                                   (λ (x)
+                                     (set-box! i (cons 5 (unbox i)))
+                                     #t))]))
+                 (contract
+                  (->i ([i (box/c (listof integer?))])
+                      (values [_ (i)
+                                 (begin
+                                   (set-box! i (cons 1 (unbox i)))
+                                   (λ (x)
+                                     (set-box! i (cons 4 (unbox i)))
+                                     #t))]
+                              [_ (i)
+                                 (begin
+                                   (set-box! i (cons 2 (unbox i)))
+                                   (λ (x)
+                                     (set-box! i (cons 5 (unbox i)))
+                                     #t))]))
+                  (λ (i)
+                   (set-box! i (cons 3 (unbox i)))
+                   (values 2 2))
+                  'pos 'neg)
+                 (quote pos)
+                 (quote neg))
+       b)
+      (unbox b))
+   '(5 4 5 4 3 2 1 2 1)
+   do-not-double-wrap)
   
   (test/pos-blame
    '->i45
@@ -875,7 +905,31 @@
        1)
       x)
    '(res-check res-eval body arg-eval)
-   '(res-check res-eval res-check res-eval body arg-eval arg-eval)) ; result if contract is applied twice
+   do-not-double-wrap)
+
+  (test/spec-passed/result
+   '->i48-double-wrap
+   '(let ([x '()])
+      ((contract (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)])
+                      [res () (begin
+                                (set! x (cons 'res-eval x))
+                                (λ (res)
+                                  (set! x (cons 'res-check x))))])
+                 (contract
+                  (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)])
+                      [res () (begin
+                                (set! x (cons 'res-eval x))
+                                (λ (res)
+                                  (set! x (cons 'res-check x))))])
+                  (λ (arg)
+                   (set! x (cons 'body x)))
+                  'pos 'neg)
+                 'pos
+                 'neg)
+       1)
+      x)
+   '(res-check res-eval res-check res-eval body arg-eval arg-eval)
+   do-not-double-wrap)
   
   (test/spec-passed/result
    '->i49
@@ -892,8 +946,32 @@
        1)
       x)
    '(res-check body res-eval arg-eval)
-   '(res-check res-check body res-eval res-eval arg-eval arg-eval)) ; result if contract is applied twice
-  
+   do-not-double-wrap)
+
+  (test/spec-passed/result
+   '->i49-double-wrap
+   '(let ([x '()])
+      ((contract (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)])
+                      [_ () (begin
+                              (set! x (cons 'res-eval x))
+                              (λ (res)
+                                (set! x (cons 'res-check x))))])
+                 (contract
+                  (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)])
+                      [_ () (begin
+                              (set! x (cons 'res-eval x))
+                              (λ (res)
+                                (set! x (cons 'res-check x))))])
+                  (λ (arg)
+                   (set! x (cons 'body x)))
+                  'pos 'neg)
+                 'pos
+                 'neg)
+       1)
+      x)
+   '(res-check res-check body res-eval res-eval arg-eval arg-eval)
+   do-not-double-wrap)
+
   (test/spec-passed/result
    '->i50
    '(let ([x '()])
@@ -909,7 +987,31 @@
        1)
       x)
    '(res-check body res-eval arg-eval)
-   '(res-check res-check body res-eval arg-eval res-eval arg-eval)) ; result if contract is applied twice
+   do-not-double-wrap)
+
+  (test/spec-passed/result
+   '->i50-double-wrap
+   '(let ([x '()])
+      ((contract (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)])
+                      [res (begin
+                             (set! x (cons 'res-eval x))
+                             (λ (res)
+                               (set! x (cons 'res-check x))))])
+                 (contract
+                  (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)])
+                      [res (begin
+                             (set! x (cons 'res-eval x))
+                             (λ (res)
+                               (set! x (cons 'res-check x))))])
+                  (λ (arg)
+                    (set! x (cons 'body x)))
+                  'pos 'neg)
+                 'pos
+                 'neg)
+       1)
+      x)
+   '(res-check res-check body res-eval arg-eval res-eval arg-eval)
+   do-not-double-wrap)
   
   (test/spec-passed/result
    '->i51
@@ -926,7 +1028,31 @@
        1)
       x)
    '(res-check body res-eval arg-eval)
-   '(res-check res-check body res-eval arg-eval res-eval arg-eval)) ; result if contract is applied twice
+   do-not-double-wrap)
+
+  (test/spec-passed/result
+   '->i51-double-wrap
+   '(let ([x '()])
+      ((contract (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)])
+                      [_ (begin
+                           (set! x (cons 'res-eval x))
+                           (λ (res)
+                             (set! x (cons 'res-check x))))])
+                 (contract
+                  (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)])
+                      [_ (begin
+                           (set! x (cons 'res-eval x))
+                           (λ (res)
+                             (set! x (cons 'res-check x))))])
+                  (λ (arg)
+                   (set! x (cons 'body x)))
+                  'pos 'neg)
+                 'pos
+                 'neg)
+       1)
+      x)
+   '(res-check res-check body res-eval arg-eval res-eval arg-eval)
+   do-not-double-wrap)
   
   (test/spec-passed/result
    '->i52
@@ -965,9 +1091,25 @@
        1 2)
       b)
    '(3 2 1)
+   do-not-double-wrap)
 
-   ;; this is probably right (but not what we really really want, of course)
-   '(3 2 1 2 1))
+  (test/spec-passed/result
+   '->i55-double-wrap
+   '(let ([b '()])
+      ((contract (->i ([y () (begin (set! b (cons 1 b)) any/c)]
+                       [z (y) (begin (set! b (cons 2 b)) any/c)])
+                      any)
+                 (contract
+                  (->i ([y () (begin (set! b (cons 1 b)) any/c)]
+                       [z (y) (begin (set! b (cons 2 b)) any/c)])
+                      any)
+                  (λ args (set! b (cons 3 b)) 0)
+                  'pos 'neg)
+                 'pos 'neg)
+       1 2)
+      b)
+   '(3 2 1 2 1)
+   do-not-double-wrap)
 
   (test/spec-passed/result
    '->i56
@@ -982,9 +1124,29 @@
        1 2)
       b)
    '(5 4 3 2 1)
+   do-not-double-wrap)
 
-   ;; this is probably right (but not what we really really want, of course)
-   '(5 4 5 4 3 2 1 2 1))
+  (test/spec-passed/result
+   '->i56-double-wrap
+   '(let ([b '()])
+      ((contract (->i ([y () (begin (set! b (cons 1 b)) any/c)]
+                       [z (y) (begin (set! b (cons 2 b)) any/c)])
+                      (values
+                       [a () (begin (set! b (cons 4 b)) any/c)]
+                       [b (a) (begin (set! b (cons 5 b)) any/c)]))
+                 (contract
+                  (->i ([y () (begin (set! b (cons 1 b)) any/c)]
+                       [z (y) (begin (set! b (cons 2 b)) any/c)])
+                      (values
+                       [a () (begin (set! b (cons 4 b)) any/c)]
+                       [b (a) (begin (set! b (cons 5 b)) any/c)]))
+                  (λ args (set! b (cons 3 b)) (values 0 0))
+                  'pos 'neg)
+                 'pos 'neg)
+       1 2)
+      b)
+   '(5 4 5 4 3 2 1 2 1)
+   do-not-double-wrap)
 
   (test/spec-passed/result
    '->i57
@@ -1003,9 +1165,37 @@
        1 2)
       b)
    '(9 8 7 6 5 4 3 2 1)
+   do-not-double-wrap)
 
-   ;; this is probably right (but not what we really really want, of course)
-   '(9 8 7 6 9 8 7 6 5 4 3 2 1 4 3 2 1))
+  (test/spec-passed/result
+   '->i57-double-wrap
+   '(let ([b '()])
+      ((contract (->i ([y () (begin (set! b (cons 1 b))
+                                    (λ (y) (set! b (cons 2 b)) #t))]
+                       [z (y) (begin (set! b (cons 3 b))
+                                     (λ (y) (set! b (cons 4 b)) #t))])
+                      (values
+                       [a () (begin (set! b (cons 6 b))
+                                    (λ (a) (set! b (cons 7 b)) #t))]
+                       [b (a) (begin (set! b (cons 8 b))
+                                     (λ (a) (set! b (cons 9 b)) #t))]))
+                 (contract
+                  (->i ([y () (begin (set! b (cons 1 b))
+                                    (λ (y) (set! b (cons 2 b)) #t))]
+                       [z (y) (begin (set! b (cons 3 b))
+                                     (λ (y) (set! b (cons 4 b)) #t))])
+                      (values
+                       [a () (begin (set! b (cons 6 b))
+                                    (λ (a) (set! b (cons 7 b)) #t))]
+                       [b (a) (begin (set! b (cons 8 b))
+                                     (λ (a) (set! b (cons 9 b)) #t))]))
+                  (λ args (set! b (cons 5 b)) (values 0 0))
+                  'pos 'neg)
+                 'pos 'neg)
+       1 2)
+      b)
+   '(9 8 7 6 9 8 7 6 5 4 3 2 1 4 3 2 1)
+   do-not-double-wrap)
 
   (test/spec-passed/result
    '->i58
@@ -1028,7 +1218,26 @@
                  'pos 'neg))
       b)
    '(3 2 1)
-   '(3 2 1 2 1))
+   do-not-double-wrap)
+
+  (test/spec-passed/result
+   '->i59-double-wrap
+   '(let ([b '()])
+      ((contract (->i ()
+                      ([x (begin (set! b (cons 1 b)) integer?)]
+                       [y (x) (begin (set! b (cons 'nope b)) (>=/c x))])
+                      [result (begin (set! b (cons 2 b)) any/c)])
+                 (contract
+                  (->i ()
+                      ([x (begin (set! b (cons 1 b)) integer?)]
+                       [y (x) (begin (set! b (cons 'nope b)) (>=/c x))])
+                      [result (begin (set! b (cons 2 b)) any/c)])
+                  (λ ([x #f] [y #f]) (set! b (cons 3 b)) 0)
+                  'pos 'neg)
+                 'pos 'neg))
+      b)
+   '(3 2 1 2 1)
+   do-not-double-wrap)
   
   (test/pos-blame
    '->i-arity1
@@ -1448,7 +1657,21 @@
                  'neg))
       x)
    '(body ctc)
-   '(body ctc ctc)) ; result if contract is applied twice
+   do-not-double-wrap)
+
+  (test/spec-passed/result
+   '->i-underscore2-double-wrap
+   '(let ([x '()])
+      ((contract (->i () () [_ (begin (set! x (cons 'ctc x)) any/c)])
+                 (contract
+                  (->i () () [_ (begin (set! x (cons 'ctc x)) any/c)])
+                  (λ () (set! x (cons 'body x)))
+                  'pos 'neg)
+                 'pos
+                 'neg))
+      x)
+   '(body ctc ctc)
+   do-not-double-wrap)
   
   (test/spec-passed/result
    '->i-underscore3
@@ -1459,7 +1682,21 @@
                  'neg))
       x)
    '(body ctc)
-   '(body ctc ctc)) ; result if contract is applied twice
+   do-not-double-wrap)
+
+  (test/spec-passed/result
+   '->i-underscore3-double-wrap
+   '(let ([x '()])
+      ((contract (->i () () [res (begin (set! x (cons 'ctc x)) any/c)])
+                 (contract
+                  (->i () () [res (begin (set! x (cons 'ctc x)) any/c)])
+                  (λ () (set! x (cons 'body x)))
+                  'pos 'neg)
+                 'pos
+                 'neg))
+      x)
+   '(body ctc ctc)
+   do-not-double-wrap)
   
   (test/spec-passed/result
    '->i-underscore4
@@ -1487,7 +1724,22 @@
        11)
       x)
    '(body ctc)
-   '(body ctc ctc)) ; result if contract is applied twice
+   do-not-double-wrap)
+
+  (test/spec-passed/result
+   '->i-underscore6-double-wrap
+   '(let ([x '()])
+      ((contract (->i ([a integer?]) () [_ (a) (begin (set! x (cons 'ctc x)) any/c)])
+                 (contract
+                  (->i ([a integer?]) () [_ (a) (begin (set! x (cons 'ctc x)) any/c)])
+                  (λ (a) (set! x (cons 'body x)))
+                  'pos 'neg)
+                 'pos
+                 'neg)
+       11)
+      x)
+   '(body ctc ctc)
+   do-not-double-wrap)
   
   (test/pos-blame
    '->i-bad-number-of-result-values1
diff --git a/pkgs/racket-test/tests/racket/contract/blame.rkt b/pkgs/racket-test/tests/racket/contract/blame.rkt
index c2a410dc46..0e3ea3385f 100644
--- a/pkgs/racket-test/tests/racket/contract/blame.rkt
+++ b/pkgs/racket-test/tests/racket/contract/blame.rkt
@@ -3,7 +3,8 @@
 
 (parameterize ([current-contract-namespace
                 (make-basic-contract-namespace 'racket/contract
-                                               'racket/contract/private/blame)])
+                                               'racket/contract/private/blame
+                                               'syntax/srcloc)])
 
   (test/spec-passed/result
    'blame-selector.1
@@ -371,6 +372,16 @@
    '(has-complete-blame? (contract (vectorof integer?) (vector 1 2 3) 'pos 'neg))
    #t)
 
+  (test/spec-passed/result
+   'complete-prop-blame-vector/c
+   '(let* ([ctc (vector/c (-> integer? integer?))]
+           [v (contract
+               ctc
+               (contract ctc (vector add1) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (has-complete-blame? (vector-ref v 0)))
+   #t)
+
   (test/spec-passed/result
    'blame-selectors
    '(let ()
@@ -394,10 +405,12 @@
                                  (λ (val np)
                                    val)))
                 'whatevs
-                'pos 'neg)
+                'pos 'neg
+                'there-is-no-name
+                (build-source-location #f))
       (list source pos neg ctc val orig? swapped?))
    (list (srcloc #f #f #f #f #f)
-         'pos #f 'blame-selector-helper #f #t #f))
+         'pos #f 'blame-selector-helper 'there-is-no-name #t #f))
 
   (test/spec-passed/result
    'swapped-blame-selectors
@@ -425,10 +438,12 @@
             any))
       (contract the-ctc
                 (λ (x) 'whatevs)
-                'pos 'neg)
+                'pos 'neg
+                'there-is-no-name
+                (build-source-location #f))
       (list source pos neg ctc val orig? swapped?))
    (list (srcloc #f #f #f #f #f)
-         #f 'pos '(-> blame-selector-helper any) #f #f #t))
+         #f 'pos '(-> blame-selector-helper any) 'there-is-no-name #f #t))
 
   (test/spec-passed/result
    'blame-equality
diff --git a/pkgs/racket-test/tests/racket/contract/collapsible-arrow.rkt b/pkgs/racket-test/tests/racket/contract/collapsible-arrow.rkt
new file mode 100644
index 0000000000..ef4a8a4085
--- /dev/null
+++ b/pkgs/racket-test/tests/racket/contract/collapsible-arrow.rkt
@@ -0,0 +1,929 @@
+#lang racket/base
+(require "test-util.rkt")
+
+(parameterize ([current-contract-namespace
+                (make-basic-contract-namespace 
+                 'racket/contract)])
+
+  (contract-eval
+   '(define (add-many-contracts n ctc val [pos 'pos] [neg 'neg])
+      (for/fold ([val val])
+                ([i (in-range n)])
+        (contract ctc val pos neg))))
+
+  (contract-eval '(define ctc (-> (-> integer? integer?) (-> integer? integer?))))
+  (contract-eval '(define (wrap x) (add-many-contracts 11 ctc x 'pos 'neg)))
+  (contract-eval '(define id (wrap (wrap (lambda (x) x)))))
+
+  (test/spec-passed
+   'collapsible1
+   '(id add1))
+  (test/spec-passed
+   'collapsible2
+   '((id add1) 1))
+  (test/spec-failed
+   'collapsible3
+   '((id add1) 'a)
+   'neg)
+  (test/spec-passed
+   'collapsible4
+   '(((wrap id) add1) 1))
+  (test/spec-failed
+   'collapsible5
+   '(((wrap id) add1) 'a)
+   'neg)
+  (test/spec-passed
+   'collapsible6
+   '(((wrap (wrap (wrap (wrap (wrap (wrap (wrap (wrap (wrap id))))))))) add1) 1))
+  (test/spec-failed
+   'collapsible7
+   '(wrap 3)
+   'pos)
+
+  ;; works with non-flat contracts at the leaves
+  (test/spec-passed
+   'collapsible8
+   '(let ([ctc (-> (vector/c integer?) (vector/c integer?))])
+      (vector-ref ((contract ctc
+                             (add-many-contracts 11 ctc
+                                       (lambda (x) x)
+                                       'inner-pos 'inner-neg)
+                             'pos 'neg)
+                   (vector 1))
+                  0)))
+  (test/spec-failed
+   'collapsible9
+   '(vector-ref ((contract ctc
+                           (add-many-contracts 11 ctc
+                                     (lambda (x) x)
+                                     'inner-pos 'inner-neg)
+                           'pos 'neg)
+                 (vector 'a))
+                0)
+   'neg)
+  (test/spec-failed
+   'collapsible10
+   '(let ([ctc (-> any/c (-> integer? integer?))])
+      (vector-ref ((contract ctc
+                             (add-many-contracts 11 ctc
+                                       (lambda (x) x)
+                                       'inner-pos 'inner-neg)
+                             'pos 'neg)
+                   (vector 'a))
+                  0))
+   "inner-pos")
+
+  (contract-eval '(require (submod racket/contract/private/arrow-collapsible for-testing)))
+  (contract-eval '(require (submod racket/contract/private/collapsible-common for-testing)))
+  (contract-eval
+   '(define (has-num-contracts? f dom rng)
+      (unless (has-impersonator-prop:collapsible? f)
+        (error "has-num-contracts?: no collapsible contract"))
+      (define collapsible/c  (collapsible-property-c-c (get-impersonator-prop:collapsible f)))
+      (define domain/c (car (collapsible->-doms collapsible/c)))
+      (define range/c  (collapsible->-rng  collapsible/c))
+      (unless (= (length (collapsible-leaf/c-proj-list domain/c)) dom)
+        (error "has-num-contracts?: wrong number of domain projections"))
+      (unless (= (length (collapsible-leaf/c-proj-list range/c))  rng)
+        (error "has-num-contracts?: wrong number of range projections"))
+      (unless (= (length (collapsible-leaf/c-contract-list domain/c)) dom)
+        (error "has-num-contracts?: wrong num of domain contracts"))
+      (unless (= (length (collapsible-leaf/c-contract-list range/c))  rng)
+        (error "has-num-contracts?: wrong num of range contracts"))))
+  (contract-eval '(define (collapsible? val)
+                    (and (has-impersonator-prop:collapsible? val)
+                         (let ([prop (get-impersonator-prop:collapsible val #f)])
+                           (and (collapsible-wrapper-property? prop)
+                                (eq? val (collapsible-property-ref prop)))))))
+
+  (contract-eval '(define pos (flat-named-contract
+                               'pos
+                               (lambda (x) (and (integer? x) (>= x 0))))))
+  (contract-eval '(define pos->pos (-> pos pos)))
+  (contract-eval '(define pos->pos->pos (-> pos->pos pos)))
+
+  (contract-eval
+   '(define guarded
+      (add-many-contracts 11 pos->pos (lambda (x) (* x -2)) 'positive 'negative)))
+  (contract-eval
+   '(define f1 (add-many-contracts 11 pos->pos->pos
+                         (flat-named-contract
+                          'c
+                          (lambda (f)
+                            (unless (has-contract? f)
+                              (error "f1 should already be contracted"))
+                            ;; Check that the already contracted function only
+                            ;; has one contract
+                            (has-num-contracts? f 1 1)
+                            (f 1)))
+                          'pos 'neg)))
+  (contract-eval
+   '(define f2 (add-many-contracts 11 pos->pos->pos
+                         (lambda (f)
+                           (unless (has-contract? f)
+                             (error "f2 should already be contracted"))
+                           ;; Check that the already contracted function only
+                           ;; has one contract
+                           (has-num-contracts? f 1 1)
+                           (f -1))
+                         'pos 'neg)))
+
+  (test/spec-failed
+   'collapsible11
+   '(f1 guarded)
+   "positive")
+  (test/spec-failed
+   'collapsible12
+   '(f2 guarded)
+   'pos)
+  ;; check whether it has a contract (but not a collapsible wrapper)
+  (test-false
+   'collapsible12.5
+   '(collapsible->? (value-contract guarded)))
+  ;; checking normal blame
+  (test/spec-failed
+   'collapsible13
+   '(guarded -34)
+   "negative")
+  (test/spec-failed
+   'collapsible14
+   '(guarded 34)
+   "positive")
+
+  (contract-eval
+   '(define guarded-twice (add-many-contracts 11 pos->pos guarded 'positive2 'negative2)))
+  ;; Reapplying the same contract over the already contracted function
+  (test-true
+   'collapsible14.5
+   '(has-contract? guarded-twice))
+  ;; Outer wrapper should be applied first for the domain
+  (test/spec-failed
+   'collapsible15
+   '(guarded-twice -34)
+   "negative2")
+  ;; Inner wrapper should be applied first for the range
+  (test/spec-failed
+   'collapsible16
+   '(guarded-twice 34)
+   "positive")
+  ;; Get the domain and range contract from the twice contracted function
+  (test/spec-passed
+   'collapsible16.1
+   '(has-num-contracts? guarded-twice 1 1))
+  (test-true
+   'collapsible16.5
+   '(collapsible? guarded-twice))
+
+  (contract-eval
+   '(define (contract-times f c n)
+      (if (= n 0)
+          f
+          (contract-times (contract c f 'positive 'negative) c (- n 1)))))
+
+  (test/spec-passed
+   'arrow-false-contracts
+   '(let* ([f (lambda (x) x)]
+           [ctc (-> #f #f)] ;; defeat opt/c rewriting
+           [cf1 (add-many-contracts 11 ctc f 'pos 'neg)]
+           [cf2 (contract ctc cf1 'pos 'neg)]
+           [cf3 (contract ctc cf2 'pos 'neg)]
+           [cf4 (contract ctc cf3 'pos 'neg)])
+      (has-num-contracts? cf4 1 1)))
+
+  (test/spec-passed
+   'arrow-many-false-contracts
+   '(let ([ctc (-> #f #f)])
+      (has-num-contracts? (contract-times (lambda (x) x) ctc 1000) 1 1)))
+
+  ;; Apply the contract 1000 times
+  (contract-eval
+   '(define insanely-contracted (contract-times guarded-twice pos->pos 1000)))
+  (test/spec-passed
+   'collapsible-wrap0
+   '(has-num-contracts? insanely-contracted 1 1))
+  ;; not actually doubly-wrapped
+
+  (contract-eval
+   '(define (double-wrapped? x)
+      (define prop (get-impersonator-prop:collapsible x #f))
+      (and
+       (collapsible-wrapper-property? prop)
+       (and (has-impersonator-prop:collapsible?
+             (collapsible-wrapper-property-checking-wrapper prop))
+            ;; this is annoying because of how unsafe-chaperones ...
+            ;; work in relation to impersonator-properties
+            (collapsible-wrapper-property?
+             (get-impersonator-prop:collapsible
+              (collapsible-wrapper-property-checking-wrapper prop)
+              #f))))))
+
+  (test-false
+   'collapsible-wrap1
+   '(double-wrapped? insanely-contracted))
+  (test-true
+   'collapsible-wrap2
+   '(collapsible? insanely-contracted))
+
+  (test-false
+   'collapsible-wrap3
+   '(double-wrapped? (id add1)))
+  (test-true
+   'collapsible-wrap4
+   '(collapsible? (id add1)))
+  (test-false
+   'collapsible-wrap5
+   '(double-wrapped? (id (id add1))))
+  (test-true
+   'collapsible-wrap6
+   '(collapsible? (id (id add1))))
+  (test-false
+   'collapsible-wrap7
+   '(double-wrapped? (id (id (id add1)))))
+  (test-true
+   'collapsible-wrap7
+   '(collapsible? (id (id (id add1)))))
+
+  ;; test relying on contract-stronger?
+  (contract-eval '(define r-i (contract (-> integer? any/c)
+                                        (add-many-contracts 11 (-> integer? integer?)
+                                                  add1
+                                                  'inner-pos 'inner-neg)
+                                        'pos 'neg)))
+  (contract-eval '(define r-i2 (contract (-> integer? any/c)
+                                         (add-many-contracts 11 (-> integer? integer?)
+                                                   (lambda (x) 'a)
+                                                   'inner-pos 'inner-neg)
+                                         'pos 'neg)))
+  (test/spec-passed
+   'collapsible-stronger-num1
+   '(has-num-contracts? r-i 1 1))
+  (test-true
+   'collapsible-stronger1
+   '(collapsible? r-i))
+  (test/spec-passed
+   'collapsible-stronger-num2
+   '(has-num-contracts? r-i2 1 1))
+  (test-true
+   'collapsible-stronger2
+   '(collapsible? r-i2))
+  (test/spec-passed
+   'collapsible17
+   '(r-i 1))
+  (test/spec-failed
+   'collapsible18
+   '(r-i 'a)
+   'neg)
+  (test/spec-failed
+   'collapsible19
+   '(r-i2 1)
+   "inner-pos")
+  (contract-eval '(define i-r (contract (-> integer? integer?)
+                                        (add-many-contracts 11 (-> integer? any/c)
+                                                  add1
+                                                  'inner-pos 'inner-neg)
+                                        'pos 'neg)))
+  (contract-eval '(define i-r2 (contract (-> integer? integer?)
+                                         (add-many-contracts 11 (-> integer? any/c)
+                                                   (lambda (x) 'a)
+                                                   'inner-pos 'inner-neg)
+                                         'pos 'neg)))
+  ;; can't collapse those. any/c must still be checked before integer? on the
+  ;; way out, otherwise may blame wrong
+  (test/spec-passed
+   'collapsible-stronger-num3
+   '(has-num-contracts? i-r 1 2))
+  (test/spec-passed
+   'collapsible-stronger-num4
+   '(has-num-contracts? i-r2 1 2))
+  (test-true
+   'collapsible-stronger3
+   '(collapsible? i-r))
+  (test-true
+   'collapsible-stronger4
+   '(collapsible? i-r2))
+  (test/spec-passed
+   'collapsible20
+   '(i-r 1))
+  (test/spec-failed
+   'collapsible21
+   '(i-r 'a)
+   'neg)
+  (test/spec-failed
+   'collapsible22
+   '(i-r2 1)
+   'pos)
+
+  ;; test mixing chaperone and impersonator contracts
+  (contract-eval
+   '(define c1 ; this is an impersonator contract
+      (make-contract
+       #:name 'c1
+       #:val-first-projection
+       (lambda (blame)
+         (lambda (x)
+           (lambda (neg-party)
+             (unless (integer? x)
+               (raise-blame-error (blame-add-missing-party blame neg-party) x "eh"))
+             (add1 x))))))) ; does not respect the chaperone property
+  (contract-eval
+   '(define c2 ; this is an chaperone contract
+      (make-chaperone-contract
+       #:name 'c2
+       #:val-first-projection
+       (lambda (blame)
+         (lambda (x)
+           (lambda (neg-party)
+             (unless (integer? x)
+               (raise-blame-error (blame-add-missing-party blame neg-party) x "eh"))
+             x))))))
+  (contract-eval
+   '(define (can-combine? val ctc)
+      (define cv (contract ctc val 'p 'n))
+      (and (collapsible? val)
+           (collapsible? cv))))
+
+  (contract-eval '(define ic
+                    (contract (-> (-> c1 c1) (-> c1 c1))
+                              (add-many-contracts 11 (-> (-> c2 c2) (-> c2 c2))
+                                        (lambda (x) x)
+                                        'inner-pos 'inner-neg)
+                              'pos 'neg)))
+  (contract-eval '(define iic
+                    (add-many-contracts 11 (-> (-> c1 c1) (-> c1 c1))
+                              ic
+                              'outer-pos 'outer-neg)))
+
+  (contract-eval
+   '(define imp-add1
+      (impersonate-procedure add1 (lambda (x) x))))
+  (contract-eval
+   '(define chap-add1
+      (chaperone-procedure add1 (lambda (x) x))))
+
+  (test-true
+   'collapsible-imps-on-underlying-chap
+   '(collapsible? (add-many-contracts 11 (-> c1 c1) chap-add1)))
+  (test-true
+   'collapsible-chaps-on-underlying-chap
+   '(collapsible? (add-many-contracts 11 (-> c2 c2) chap-add1)))
+  (test-true
+   'collapsible-imps-on-underlying-imp
+   '(collapsible? (add-many-contracts 11 (-> c1 c1) imp-add1)))
+  (test-true
+   'collapsible-chaps-on-underlying-imp
+   '(collapsible? (add-many-contracts 11 (-> c2 c2) imp-add1)))
+
+  (test-false
+   'collapsible-chap+imp1
+   '(can-combine? ic (-> c1 c1))) ; can collapse impersonators, the inner chaperone is not chaperone*
+  (test-false
+   'collapsible-chap+imp2
+   '(can-combine? ic (-> c2 c2)))
+  (test-false
+   'collapsible-chap+imp3
+   '(can-combine? iic (-> c1 c1))) ; see above
+  (test-false
+   'collapsible-chap+imp4
+   '(can-combine? iic (-> c2 c2)))
+  (test/spec-passed
+   'collapsible23
+   '((iic add1) 1))
+
+  (contract-eval '(define cc
+                    (contract (-> (-> c2 c2) (-> c2 c2))
+                              (add-many-contracts 11 (-> (-> c2 c2) (-> c2 c2))
+                                        (lambda (x) x)
+                                        'inner-pos 'inner-neg)
+                              'pos 'neg)))
+  (contract-eval '(define icc
+                    (add-many-contracts 11 (-> (-> c1 c1) (-> c1 c1))
+                              cc
+                              'outer-pos 'outer-neg)))
+  (test-true
+   'collapsible-chap+imp5
+   '(collapsible? cc))
+  (test-false
+   'collapsible-chap+imp6
+   '(can-combine? cc (-> c1 c1)))
+  (test-true
+   'collapsible-chap+imp7
+   '(can-combine? cc (-> c2 c2)))
+  (test-false
+   'collapsible-chap+imp8
+   '(can-combine? icc (-> c1 c1)))
+  (test-false
+   'collapsible-chap+imp9
+   '(can-combine? icc (-> c2 c2)))
+  (test/spec-passed
+   'collapsible24
+   '((icc add1) 1))
+
+  (contract-eval '(define ci (contract (-> (-> c2 c2) (-> c2 c2))
+                                       (add-many-contracts 11 (-> (-> c1 c1) (-> c1 c1))
+                                                 (lambda (x) x)
+                                                 'inner-pos 'inner-neg)
+                                       'pos 'neg)))
+  (contract-eval '(define ici (add-many-contracts 11 (-> (-> c1 c1) (-> c1 c1))
+                                        ci
+                                        'outer-pos 'outer-neg)))
+  (test-false
+   'collapsible-chap+imp10
+   '(can-combine? ci (-> c1 c1)))
+  (test-false
+   'collapsible-chap+imp11
+   '(can-combine? ci (-> c2 c2))) ; it's impersonated before the `cc`, but not impersonator*, sook
+  (test-false
+   'collapsible-chap+imp12
+   '(can-combine? ici (-> c1 c1))) ; ditto
+  (test-false
+   'collapsible-chap+imp13
+   '(can-combine? ici (-> c2 c2)))
+  (test/spec-passed
+   'collapsible25
+   '((ici add1) 1))
+
+  (test/spec-passed
+   'collapsible25.5
+   ;; using `contract` explicitly, to trigger double-wrapping rewrite
+   ;; (that changed something! (but it shouldn't, so it's a bug!))
+   '(((contract (-> (-> c1 c1) (-> c1 c1))
+                (contract (-> (-> c2 c2) (-> c2 c2))
+                          (add-many-contracts 11 (-> (-> c1 c1) (-> c1 c1))
+                                    (lambda (x) x)
+                                    'inner-pos 'inner-neg)
+                          'pos 'neg)
+                'outer-pos 'outer-neg)
+      add1)
+     1))
+
+  (contract-eval '(define cic
+                    (add-many-contracts 11 (-> (-> c2 c2) (-> c2 c2))
+                              ci
+                              'outer-pos 'outer-neg)))
+  (test-false
+   'collapsible-chap+imp14
+   '(can-combine? cic (-> c1 c1)))
+  (test-false
+   'collapsible-chap+imp15
+   '(can-combine? cic (-> c2 c2)))
+  (test/spec-passed
+   'collapsible26
+   '((cic add1) 1))
+
+  ;; can we get collapsible wrappers for impersonator contracts?
+  (contract-eval
+   '(define imp-imp (contract (-> c1 c1)
+                              (add-many-contracts 11 (-> c1 c1) (lambda (x) x) 'pos 'neg)
+                              'pos 'neg)))
+  (test-true
+   'collapsible-imp1
+   '(collapsible? imp-imp))
+  (test/spec-passed
+   'collapsible27
+   '(imp-imp 1))
+  (test/spec-failed
+   'collapsible27f
+   '(imp-imp 'a)
+   'neg)
+  ;; should be an impersonator contract
+  (test-false
+   'collapsible-imp2
+   '(chaperone-contract? (value-contract imp-imp)))
+
+
+  (contract-eval '(define mix1 (contract (-> any/c any/c)
+                                         (add-many-contracts 11 (-> (-> integer? integer?)
+                                                       (-> integer? integer?))
+                                                   (lambda (x) x)
+                                                   'pos 'neg)
+                                         'pos 'neg)))
+  (contract-eval '(define mix2 (contract (-> (-> integer? integer?)
+                                             (-> integer? integer?))
+                                         (add-many-contracts 11 (-> any/c any/c)
+                                                   (lambda (x) x)
+                                                   'pos 'neg)
+                                         'pos 'neg)))
+  (test-true
+   'collapsible-flat-h/o-mix1
+   '(collapsible? mix1))
+  (test/spec-passed
+   'collapsible-flat-h/o-mix2
+   '((mix1 add1) 2))
+  (test-true
+   'collapsible-flat-h/o-mix3
+   '(collapsible? mix2))
+  (test/spec-passed
+   'collapsible-flat-h/o-mix5
+   '((mix2 add1) 2))
+  (test/neg-blame
+   'collapsible-flat-h/o-mix6
+   '((mix1 add1) 'a))
+  (test/neg-blame
+   'collapsible-flat-h/o-mix7
+   '((mix1 number->string) 2))
+  (test/neg-blame
+   'collapsible-flat-h/o-mix8
+   '((mix2 add1) 'a))
+  (test/neg-blame
+   'collapsible-flat-h/o-mix9
+   '((mix2 number->string) 2))
+
+  ;; only the outer contract matters for these tests, as the inner one is fully
+  ;; checked before we enter collapsible mode
+  (test/pos-blame
+   'collapsible-first-order-checks1
+   '(contract (-> any/c)
+              (add-many-contracts 11 (-> any/c any/c) add1 'inner-pos 'inner-neg)
+              'pos 'neg))
+  (test/pos-blame
+   'collapsible-first-order-checks2
+   '((contract (-> (-> any/c))
+               (add-many-contracts 11 (-> (-> any/c any/c))
+                         (lambda () add1)
+                         'inner-pos 'inner-neg)
+               'pos 'neg)))
+  (test/pos-blame
+   'collapsible-first-order-checks3
+   '((contract (-> (-> any/c any/c))
+               (add-many-contracts 11 (-> (-> any/c))
+                         (lambda () add1)
+                         'pos 'neg)
+               'outer-pos 'outer-neg)))
+  (test/pos-blame
+   'collapsible-first-order-checks4
+   '((contract (-> (-> any/c any/c))
+               (contract (-> (-> any/c))
+                         (add-many-contracts 11 (-> (-> any/c any/c any/c))
+                                   (lambda () add1)
+                                   'pos 'neg)
+                         'mid-pos 'mid-neg)
+               'outer-pos 'outer-neg)))
+  (test/pos-blame
+   'collapsible-first-order-checks5
+   '((contract (-> (-> any/c any/c))
+               (contract (-> (-> any/c))
+                         (add-many-contracts 11 (-> (-> any/c any/c any/c))
+                                   (contract (-> (-> any/c any/c)) ; to have next one be collapsible
+                                             (lambda () add1)
+                                             'inner-pos 'inner-neg)
+                                   'pos 'neg)
+                         'mid-pos 'mid-neg)
+               'outer-pos 'outer-neg)))
+  (test/pos-blame
+   'collapsible-first-order-checks6
+   '((contract (-> (-> any/c any/c))
+               (contract (-> (-> any/c))
+                         (add-many-contracts 11 (-> (-> any/c any/c))
+                                   (contract (-> (-> any/c any/c)) ; to have next one be collapsible
+                                             (lambda () add1)
+                                             'innermost-pos 'innermost-neg)
+                                   'inner-pos 'inner-neg)
+                         'pos 'neg)
+               'outer-pos 'outer-neg)))
+
+  (test/neg-blame
+   'collapsible-first-order-checks7
+   ;; both should fail, but want to make sure we drop the right redundant check
+   '((contract (-> (-> any/c any/c any/c) any)
+               (add-many-contracts 11 (-> (-> any/c any/c any/c) any)
+                         (lambda (x) x)
+                         'inner-pos 'inner-neg)
+               'pos 'neg)
+     add1))
+
+  ;; scenario: double-wrap (enter collapsible mode), unrelated chaperone, another contract
+  ;; want to make sure no check gets lost
+  (test/pos-blame
+   'collapsible-chaperone-in-middle
+   '(let ([x 0])
+      (define f (contract (-> any/c string?)
+                          (add-many-contracts 11 (-> any/c string?)
+                                    (lambda (x) x)
+                                    'pos 'neg)
+                          'mid-pos 'mid-neg))
+      (define f2 (chaperone-procedure f (lambda (y) y)))
+      ((add-many-contracts 11 (-> any/c integer?)
+                 f2
+                 'outer-pos 'outer-neg)
+       4)))
+
+  (test-true
+   'collapsible-bail-on-subcontract1
+   ;; Contracts lifted to defeat the opt/c rewriting
+   '(let ([ctc1 (-> (-> any/c (values any/c any/c)) any/c)]
+          [ctc2 (-> (-> any/c (values any/c any/c)) any/c)])
+      (collapsible?
+       (contract ctc1
+                 (add-many-contracts 11 ctc2
+                           (lambda (x) x)
+                           'pos 'neg)
+                 'pos 'neg))))
+  (test-true
+   'collapsible-bail-on-subcontract2
+   ;; Contracts lifted to defeat the opt/c rewriting
+   '(let ([ctc1 (-> any/c (-> any/c (values any/c any/c)) any/c)]
+          [ctc2 (-> any/c (-> any/c (values any/c any/c)) any/c)])
+      (collapsible?
+       (contract ctc1
+                 (add-many-contracts 11 ctc2
+                           (lambda (x y) x)
+                           'pos 'neg)
+                 'pos 'neg))))
+  (test-true
+   'collapsible-bail-on-subcontract3
+   ;; Contracts lifted to defeat the opt/c rewriting
+   '(let ([ctc1 (-> any/c (-> any/c (values any/c any/c)))]
+          [ctc2 (-> any/c (-> any/c (values any/c any/c)))])
+      (collapsible?
+       (contract ctc1
+                 (add-many-contracts 11 ctc2
+                           (lambda (x) x)
+                           'pos 'neg)
+                 'pos 'neg))))
+
+  (test/neg-blame
+   'collapsible-merge-subcontract1
+   '(let ()
+      (define id (contract (-> (-> string? string?) (-> string? string?))
+                           (add-many-contracts 11 (-> (-> string? string?) (-> string? string?))
+                                     (lambda (x) x)
+                                     'p1 'n1)
+                           'p2 'n2))
+      (define a1 (add-many-contracts 11 (-> integer? integer?)
+                           add1
+                           'pos 'neg))
+      ((id a1) "a")))
+  (test/neg-blame
+   'collapsible-merge-subcontract2
+   '(let ()
+      (define id (contract (-> (-> string? string?) (-> string? string?))
+                           (add-many-contracts 11 (-> (-> string? string?) (-> string? string?))
+                                     (lambda (x) x)
+                                     'p1 'n2)
+                           'pos 'neg))
+      (define a1 (add-many-contracts 11 (-> integer? integer?)
+                           (lambda (x) x)
+                           'p3 'n3))
+      ((id a1) 1)))
+  (test/spec-passed
+   'collapsible-merge-subcontract3
+   '(let ()
+      ;; lift definitions to defeat the opt/c rewriting
+      ;; (otherwise that bypasses the whole collapsible machinery)
+      (define ctc1 (-> (-> string? string?) (-> string? string?)))
+      (define ctc2 (-> string? string?))
+      (define id (contract ctc1
+                           (add-many-contracts 11 ctc1
+                                     (lambda (x) x)
+                                     'pos 'neg)
+                           'p2 'n2))
+      (define a1 (add-many-contracts 11 ctc2
+                           (lambda (x) x)
+                           'p3 'n3))
+      (has-num-contracts? (id a1) 1 1)))
+  (test/neg-blame
+   'collapsible-merge-subcontract4
+   '(let ()
+      (define id (contract (-> (-> string? string?) (-> string? string?))
+                           (add-many-contracts 11 (-> (-> string? string?) (-> string? string?))
+                                     (lambda (x) x)
+                                     'p1 'n1)
+                           'p2 'n2))
+      (define a1 (contract (-> integer? integer?)
+                           (add-many-contracts 11 (-> integer? integer?)
+                                     add1
+                                     'p3 'n3)
+                           'pos 'neg))
+      ((id a1) "a")))
+  (test/neg-blame
+   'collapsible-merge-subcontract5
+   '(let ()
+      (define id (contract (-> (-> string? string?) (-> string? string?))
+                           (add-many-contracts 11 (-> (-> string? string?) (-> string? string?))
+                                     (lambda (x) x)
+                                     'p1 'n1)
+                           'pos 'neg))
+      (define a1 (contract (-> integer? integer?)
+                           (add-many-contracts 11 (-> integer? integer?)
+                                     (lambda (x) x)
+                                     'p3 'n3)
+                           'p4 'n4))
+      ((id a1) 1)))
+  (test/spec-passed
+   'collapsible-merge-subcontract6
+   '(let ()
+      ;; lift definitions to defeat the opt/c rewriting
+      ;; (otherwise that bypasses the whole collapsible machinery)
+      (define ctc1 (-> (-> string? string?) (-> string? string?)))
+      (define ctc2 (-> string? string?))
+      (define id (contract ctc1
+                           (add-many-contracts 11 ctc1
+                                     (lambda (x) x)
+                                     'pos 'neg)
+                           'p2 'n2))
+      (define a1 (contract ctc2
+                           (add-many-contracts 11 ctc2
+                                     (lambda (x) x)
+                                     'p3 'n3)
+                           'p4 'n4))
+      (has-num-contracts? (id a1) 1 1)))
+
+  (test/spec-passed
+   'collapsible-multi-args1
+   '((contract (-> number? string? number?)
+               (add-many-contracts 11 (-> number? string? number?)
+                         (lambda (x y) x)
+                         'pos 'neg)
+               'outer-pos 'outer-neg)
+     1 "a"))
+  (test/pos-blame
+   'collapsible-multi-args2
+   '((contract (-> number? string? number?)
+               (add-many-contracts 11 (-> number? string? number?)
+                         (lambda (x) x)
+                         'pos 'neg)
+               'outer-pos 'outer-neg)
+     1 "a"))
+  (test/neg-blame
+   'collapsible-multi-args3
+   '((contract (-> number? string? number?)
+               (add-many-contracts 11 (-> number? string? number?)
+                         (lambda (x y) x)
+                         'inner-pos 'inner-neg)
+               'pos 'neg)
+     "a" "a"))
+  (test/neg-blame
+   'collapsible-multi-args4
+   '((contract (-> number? string? number?)
+               (add-many-contracts 11 (-> number? string? number?)
+                         (lambda (x y) x)
+                         'inner-pos 'inner-neg)
+               'pos 'neg)
+     1 1))
+  (test/spec-passed/result
+   'collapsible-multi-args5
+   '(with-handlers ([exn:fail:contract:arity? (lambda (e) 'ok)])
+      ((contract (-> number? string? number?)
+                 (add-many-contracts 11 (-> number? string? number?)
+                           (lambda (x y) x)
+                           'inner-pos 'inner-neg)
+                 'pos 'neg)
+       1 1 "a"))
+   'ok)
+  (test/spec-passed/result
+   'collapsible-multi-args6
+   '(with-handlers ([exn:fail:contract:arity? (lambda (e) 'ok)])
+      ((contract (-> number? string? number?)
+                 (add-many-contracts 11 (-> number? string? number?)
+                           (lambda (x y) x)
+                           'inner-pos 'inner-neg)
+                 'pos 'neg)
+       1))
+   'ok)
+  (test/spec-passed
+   'collapsible-multi-args7
+   '(collapsible? (contract (-> number? string? number?)
+                                (add-many-contracts 11 (-> number? string? number?)
+                                          (lambda (x y) x)
+                                          'inner-pos 'inner-neg)
+                                'pos 'neg)))
+
+  (contract-eval '(require racket/class))
+
+  (test/spec-passed
+   'object/c-->-pass/no-bail
+   '(let* ([grid/c (-> (-> (object/c)))]
+           [o (new object%)]
+           [v (lambda () o)]
+           [grid (contract
+                  grid/c
+                  (add-many-contracts 11
+                   grid/c
+                   (lambda () v)
+                   'inner-pos 'inner-neg)
+                  'pos 'neg)])
+      ((grid))))
+
+  (test/spec-failed
+   'object/c-->-fail/should-bail
+   '(let* ([v (add-many-contracts 11 (-> integer?) (lambda () 1) 'p 'n)]
+           [grid (contract
+                  (-> (-> (object/c)))
+                  (add-many-contracts 11
+                   (-> (-> (object/c)))
+                   (lambda () v)
+                   'inner-pos 'inner-neg)
+                  'pos 'neg)])
+      ((grid)))
+   "inner-pos")
+
+  ;; arrow and vector contracts
+  (test/spec-failed
+   'arrow+vector
+   '(let* ([ctc (-> (vectorof integer?))]
+           [f (contract ctc
+                        (add-many-contracts 11 ctc (lambda () (vector 1)) 'inner-pos 'inner-neg)
+                        'pos 'neg)])
+      (vector-set! (f) 0 1.5))
+   "neg")
+
+  ;; arrow and box
+  (test/spec-failed
+   'arrow+box
+   '(let* ([ctc (-> (box/c integer?))]
+           [f (contract ctc (add-many-contracts 11 ctc (lambda () (box 1)) 'inner-pos 'inner-neg) 'pos 'neg)])
+      (set-box! (f) 1.5))
+   "neg")
+
+  (test/spec-failed
+   'arrow-symbol-multi-pos1
+   '(let* ([ctc1 (-> integer? (-> symbol? symbol?))]
+           [ctc2 (-> integer? symbol?)]
+           [f (lambda (x) (lambda (y) y))]
+           [cf (contract ctc2 (add-many-contracts 11 ctc1 f 'inner-pos 'inner-neg) 'pos 'neg)])
+      (cf 0))
+   "pos")
+
+  (test/spec-failed
+   'arrow-symbol-multi-pos2
+   '(let* ([ctc1 (-> integer? (-> symbol? symbol?))]
+           [ctc2 (-> integer? symbol?)]
+           [f (lambda (x) 'foo)]
+           [cf (contract ctc2 (add-many-contracts 11 ctc1 f 'inner-pos 'inner-neg) 'pos 'neg)])
+      (cf 0))
+   "inner-pos")
+
+  (test/spec-failed
+   'arrow-symbol-multi-neg1
+   '(let* ([ctc1 (-> symbol? integer?)]
+           [ctc2 (-> (-> symbol? symbol?) integer?)]
+           [f (lambda (x) 0)]
+           [cf (contract ctc2 (add-many-contracts 11 ctc1 f 'inner-pos 'inner-neg) 'pos 'neg)])
+      (cf (lambda (x) x)))
+   "inner-neg")
+
+  (test/spec-failed
+   'arrow-symbol-multi-neg2
+   '(let* ([ctc1 (-> symbol? integer?)]
+           [ctc2 (-> (-> symbol? symbol?) integer?)]
+           [f (lambda (x) 0)]
+           [cf (contract ctc2 (add-many-contracts 11 ctc1 f 'inner-pos 'inner-neg) 'pos 'neg)])
+      (cf 'foo))
+   "neg")
+
+  (test/spec-passed/result
+   'calculate-drops-1
+   '(let* ([ctc1 (coerce-contract/f integer?)]
+           [ctc2 (coerce-contract/f string?)]
+           [ctcs (list ctc1 ctc2 ctc1 ctc2 ctc1)])
+      (calculate-drops ctcs))
+   '(2))
+
+  (test/spec-passed/result
+   'calculate-drops-2
+   '(let* ([ctc1 (coerce-contract/f integer?)]
+           [ctcs (list ctc1 ctc1 ctc1 ctc1 ctc1)])
+      (calculate-drops ctcs))
+   '(3 2 1))
+
+  (test/spec-passed/result
+   'calculate-drops-2
+   '(let* ([ctc1 (coerce-contract/f (object/c))]
+           [ctcs (list ctc1 ctc1 ctc1 ctc1 ctc1)])
+      (calculate-drops ctcs))
+   '())
+
+  (test/spec-passed/result
+   'calculate-drops-3
+   '(let* ([ctc1 (coerce-contract/f integer?)]
+           [ctc2 (coerce-contract/f string?)]
+           [ctcs (list ctc1 ctc2 ctc1 ctc2 ctc1)])
+      (calculate-drops ctcs))
+   '(2))
+
+  (test/spec-passed/result
+   'calculate-drops-4
+   '(let* ([c1 (coerce-contract/f integer?)]
+           [c2 (coerce-contract/f (vectorof integer?))]
+           [c3 (coerce-contract/f (-> integer? integer?))]
+           [ctcs (list c1 c2 c3 c2 c3 c1 c3 c2 c1)])
+      (calculate-drops ctcs))
+   '(5 3 4))
+
+  (test/spec-passed/result
+   'calculate-drops-5
+   '(let* ([c1 (coerce-contract/f integer?)]
+           [c2 (coerce-contract/f (vectorof integer?))]
+           [c3 (coerce-contract/f (-> integer? integer?))]
+           [c4 (coerce-contract/f (object/c))]
+           [ctcs (list c1 c2 c3 c4 c4 c2 c3 c1 c3 c2 c4 c1 c4)])
+      (calculate-drops ctcs))
+   '(7 5 6))
+
+  (test/spec-passed/result
+   'calculate-drops-6
+   '(let* ([c1 (coerce-contract/f integer?)]
+           [ctcs (list c1 c1 c1 c1 c1 c1 c1 c1 c1)])
+      (calculate-drops ctcs))
+   '(7 6 5 4 3 2 1))
+  )
diff --git a/pkgs/racket-test/tests/racket/contract/collapsible-vector.rkt b/pkgs/racket-test/tests/racket/contract/collapsible-vector.rkt
new file mode 100644
index 0000000000..c828072ec9
--- /dev/null
+++ b/pkgs/racket-test/tests/racket/contract/collapsible-vector.rkt
@@ -0,0 +1,1455 @@
+#lang racket/base
+(require "test-util.rkt")
+
+(parameterize ([current-contract-namespace
+                (make-basic-contract-namespace
+                 'racket/contract
+                 'racket/contract/collapsible)])
+
+  (contract-eval
+   '(define (add-many-contracts n ctc val [pos 'pos] [neg 'neg])
+      (for/fold ([val val])
+                ([i (in-range n)])
+        (contract ctc val pos neg))))
+  
+  (contract-eval '(define ctc (vectorof integer?)))
+  (contract-eval '(define (wrap x) (contract ctc x 'pos 'neg)))
+  (contract-eval '(define vecof-one (wrap (wrap (vector 1)))))
+  (contract-eval '(define bad-vecof-int (wrap (wrap (vector 'bad)))))
+
+  (test/spec-passed
+   'vec-collapsible1
+   '(vector-ref vecof-one 0))
+  (test/spec-passed
+   'vec-collapsible2
+   '(vector-set! vecof-one 0 2))
+  (test/spec-failed
+   'vec-collapsible3
+   '(vector-set! vecof-one 0 'nan)
+   'neg)
+  (test/spec-failed
+   'vec-collapsible4
+   '(vector-ref bad-vecof-int 0)
+   'pos)
+
+  (test/spec-failed
+   'vecof-bail-not-a-vector
+   '(let* ([ctc (vectorof (vectorof integer?))]
+           [v (contract ctc (add-many-contracts 11 ctc (vector 1) 'inner-pos 'inner-neg) 'pos 'neg)])
+      (vector-ref v 0))
+   "inner-pos")
+
+  (test/spec-failed
+   'vec/c-bail-not-a-vector
+   '(let* ([ctc (vector/c (vector/c integer?))]
+           [v (contract ctc (add-many-contracts 11 ctc (vector 1) 'inner-pos 'inner-neg) 'pos 'neg)])
+      (vector-ref v 0))
+   "inner-pos")
+
+  (test/spec-failed
+   'vec/c-different-lengths1
+   '(let* ([ctc1 (vector/c integer?)]
+           [ctc2 (vector/c integer? integer?)]
+           [v (contract ctc1 (add-many-contracts 11 ctc2 (vector 1) 'inner-pos 'inner-neg) 'pos 'neg)])
+      (vector-ref v 0))
+   "inner-pos")
+
+  (test/spec-failed
+   'vec/c-different-lengths2
+   '(let* ([ctc1 (vector/c integer?)]
+           [ctc2 (vector/c integer? integer?)]
+           [v (contract ctc2 (add-many-contracts 11 ctc1 (vector 1) 'inner-pos 'inner-neg) 'pos 'neg)])
+      (vector-ref v 0))
+   'pos)
+
+  (test/spec-failed
+   'vec/c-different-lengths3
+   '(let* ([ctc1 (vector/c integer?)]
+           [ctc2 (vector/c integer? integer?)]
+           [v (contract ctc1 (add-many-contracts 11 ctc2 (vector 1) 'inner-pos 'inner-neg) 'pos 'neg)])
+      (vector-set! v 0 7))
+   "inner-pos")
+
+  (test/spec-failed
+   'vec/c-different-lengths4
+   '(let* ([ctc1 (vector/c integer?)]
+           [ctc2 (vector/c integer? integer?)]
+           [v (contract ctc2 (add-many-contracts 11 ctc1 (vector 1) 'inner-pos 'inner-neg) 'pos 'neg)])
+      (vector-set! v 0 7))
+   'pos)
+
+  ;; Testing basic keyword arguments
+  ;; ***********************************************
+
+  ;; If the flat? argument is #t, then the resulting contract is a flat contract, and the c argument must also be a flat contract.
+  ;; Such flat contracts will be unsound if applied to mutable vectors, as they will not check future operations on the vector.
+  (test/spec-passed 
+   'vec-collapsible-flat-passed
+   '(let* ([ctc 	(vectorof integer? #:flat? #t)]
+           [v 	(add-many-contracts 11
+                                    ctc 
+                                    (make-vector 10 42) 'pos 'neg )])
+      (vector-ref v 1)))
+  
+  (test/spec-failed
+   'vec-collapsible-flat-failed!
+   '(let* ([ctc    (vectorof integer? #:flat? #t)]
+           [v      (add-many-contracts 11
+                                       ctc 
+                                       (make-vector 10 "42") 'pos 'neg )])
+      'oeps)
+   "pos")
+  
+  ;;Should pass the test because we indicate that it is a flat contract
+  (test/spec-passed
+   'vec-collapsible-flat-set!
+   '(let* ([ctc 	(vectorof integer? #:flat? #t)]
+           [v 	(add-many-contracts
+                 11
+                 ctc 
+                 (make-vector 10 42) 'pos 'neg )])
+      (vector-set! v 1 "24")))
+  
+  ;If the immutable argument is #t and the c argument is a flat contract and the eager argument is #t, the result will be a flat contract. 
+  (contract-eval  '(define ctc-flat (vectorof integer? #:immutable #t #:eager #t)))
+  (test-true 'is-flat '(flat-contract? ctc-flat))
+  
+  (test/spec-failed
+   'vec-collapsible-flat-set!
+   '(let* ([ctc 	(vectorof integer? #:immutable #t #:eager #t)]
+           [v 	(add-many-contracts
+                 11
+                 ctc 
+                 (make-vector 10 42) 'pos 'neg )])
+      'should-fail)
+   "pos")
+  
+  (test/spec-passed
+   'vec-collapsible-flat-set!
+   '(let* ([ctc 	(vectorof integer? #:immutable #t #:eager #t)]
+           [v 	(add-many-contracts
+                 11
+                 ctc 
+                 (vector-immutable 10 42) 'pos 'neg )])
+      (vector-ref v 1)))
+  
+   ;If the c argument is a chaperone contract, then the result will be a chaperone contract.
+   (contract-eval '(define ctc-chap (vectorof (-> integer? integer?) #:immutable #t #:eager #t )))
+   (test-true 'is-chaperone '(chaperone-contract? ctc-chap))
+
+
+  (test/spec-passed
+   'vec-collapsible-vector-chap
+   '(let* ([ctc-chap    (vectorof (-> integer? integer?) #:immutable #t #:eager #t)]
+           [v      (add-many-contracts
+                    11
+                    ctc-chap 
+                    (vector-immutable (lambda (x) x)  (lambda (x) (* x x))) 'pos 'neg )])
+      ((vector-ref v 1) 10)))
+  
+   (test/spec-failed
+    'vec-collapsible-vector-chap-fail
+    '(let* ([ctc-chap    (vectorof (-> integer? integer?) #:immutable #t #:eager #t)]
+            [v      (add-many-contracts
+                     11
+                     ctc-chap 
+                     (vector-immutable (lambda (x) "42")) 'pos 'neg )])
+       ((vector-ref v 0) 10))
+    "pos")
+
+  ;; End basic keyword arguments
+  ;; ***********************************************
+
+
+  ;; non-flat contracts at the leaves/nested vectorof contracts
+  (test/spec-passed
+   'vec-collapsible5
+   '(let* ([ctc (vectorof (vectorof integer?))]
+           [v (contract
+               ctc
+               (add-many-contracts 11 ctc (vector (vector 0) (vector 1) (vector 2)) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (vector-ref (vector-ref v 1) 0)))
+
+  (test/spec-failed
+   'vec-collapsible6a
+   '(let* ([ctc (vectorof (vectorof integer?))]
+           [v (add-many-contracts 11 ctc (vector (vector 'bad)) 'inner-pos 'inner-neg)])
+      (vector-ref (vector-ref v 0) 0))
+   "inner-pos")
+  
+  (test/spec-failed
+   'vec-collapsible6b
+   '(let* ([ctc (vectorof (vectorof integer?))]
+           [v (contract
+               ctc
+               (add-many-contracts 11 ctc (vector (vector 'bad)) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (vector-ref (vector-ref v 0) 0))
+   "inner-pos")
+
+  (test/spec-failed
+   'vec-collapsible7
+   '(let* ([ctc (vectorof (vectorof integer?))]
+           [v (contract
+               ctc
+               (add-many-contracts 11 ctc (vector (vector 1)) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (vector-set! (vector-ref v 0) 0 'bad))
+   'neg)
+
+  (test/spec-failed
+   'vec-collapsible8
+   '(let* ([ctc (vectorof (vectorof integer?))]
+           [v (contract
+               ctc
+               (add-many-contracts 11 ctc (vector (vector 1)) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (vector-set! v 0 (vector 'bad))
+      (vector-ref (vector-ref v 0) 0))
+   'neg)
+
+  ;; non-identical contracts in nested vectorof
+  (test/spec-failed
+   'vec-collapsible9
+   '(let* ([ctc1 (vectorof (vectorof integer?))]
+           [ctc2 (vectorof (vectorof positive?))]
+           [v (contract
+               ctc1
+               (add-many-contracts 11 ctc2 (vector (vector 1)) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (vector-set! (vector-ref v 0) 0 -1))
+   "inner-neg")
+
+  (test/spec-failed
+   'vec-collapsible10
+   '(let* ([ctc1 (vectorof (vectorof integer?))]
+           [ctc2 (vectorof (vectorof positive?))]
+           [v (contract
+               ctc1
+               (add-many-contracts 11 ctc2 (vector (vector 1)) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (vector-set! (vector-ref v 0) 0 1/2))
+   'neg)
+
+  (test/spec-failed
+   'vec-collapsible11
+   '(let* ([ctc1 (vectorof (vectorof integer?))]
+           [ctc2 (vectorof (vectorof positive?))]
+           [v (contract
+               ctc1
+               (add-many-contracts 11 ctc2 (vector (vector 1/2)) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (vector-ref (vector-ref v 0) 0))
+   'pos)
+
+  (test/spec-failed
+   'vec-collapsible12
+   '(let* ([ctc1 (vectorof (vectorof integer?))]
+           [ctc2 (vectorof (vectorof positive?))]
+           [v (contract
+               ctc1
+               (add-many-contracts 11 ctc2 (vector (vector -1)) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (vector-ref (vector-ref v 0) 0))
+   "inner-pos")
+
+  ;; tests for various first-order checks performed by vectors
+  (test/spec-failed
+   'vec-collapsible13
+   '(let* ([ctc [vectorof (vectorof integer?)]]
+           [v (contract
+               ctc
+               (add-many-contracts 11 ctc (vector (vector 1)) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (vector-set! v 0 'bad))
+   'neg)
+
+    (test/spec-failed
+   'vec-collapsible14
+   '(let* ([ctc (vectorof (vectorof integer? #:immutable #t))]
+           [v (contract
+               ctc
+               (add-many-contracts 11 ctc (vector (vector 1)) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (vector-ref v 0))
+   "inner-pos")
+
+  (test/spec-passed
+   'vectorof-impersonator
+   '(let* ([ctc (vectorof (make-contract #:late-neg-projection (lambda (b) (lambda (x n) 'foo))))]
+           [v (contract ctc (add-many-contracts 11 ctc (vector 1) 'inner-pos 'inner-neg) 'pos 'neg)])
+      (vector-ref v 0)))
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;; vector/c contract tests
+  ;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (test/spec-failed
+   'vector/c-bad-index
+   '(let* ([ctc (vector/c (vector/c integer?))]
+           [v (contract
+               ctc
+               (add-many-contracts 11 ctc (vector (vector 1 2)) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (vector-ref v 0))
+   "inner-pos")
+
+  (test/spec-passed
+   'vector/c-collapsible1
+   '(let* ([ctc (vector/c (vector/c integer?))]
+           [v (contract
+               ctc
+               (add-many-contracts 11 ctc (vector (vector 0)) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (vector-ref (vector-ref v 0) 0)))
+
+  (test/spec-failed
+   'vector/c-collapsible2
+   '(let* ([ctc (vector/c (vector/c integer?))]
+           [v (add-many-contracts 11 ctc (vector (vector 'bad)) 'inner-pos 'inner-neg)])
+      (vector-ref (vector-ref v 0) 0))
+   "inner-pos")
+
+  (test/spec-failed
+   'vector/c-collapsible3
+   '(let* ([ctc (vector/c (vector/c integer?))]
+           [v (contract
+               ctc
+               (add-many-contracts 11 ctc (vector (vector 'bad)) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (vector-ref (vector-ref v 0) 0))
+   "inner-pos")
+
+  (test/spec-failed
+   'vector/c-collapsible4
+   '(let* ([ctc (vector/c (vector/c integer?))]
+           [v (contract
+               ctc
+               (add-many-contracts 11 ctc (vector (vector 1)) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (vector-set! (vector-ref v 0) 0 'bad))
+   'neg)
+
+  (test/spec-failed
+   'vector/c-collapsible5
+   '(let* ([ctc (vector/c (vector/c integer?))]
+           [v (contract
+               ctc
+               (add-many-contracts 11 ctc (vector (vector 1)) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (vector-set! v 0 (vector 'bad))
+      (vector-ref (vector-ref v 0) 0))
+   'neg)
+
+  ;; non-identical contracts in nested vectorof
+  (test/spec-failed
+   'vector/c-collapsible6
+   '(let* ([ctc1 (vector/c (vector/c integer?))]
+           [ctc2 (vector/c (vector/c positive?))]
+           [v (contract
+               ctc1
+               (add-many-contracts 11 ctc2 (vector (vector 1)) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (vector-set! (vector-ref v 0) 0 -1))
+   "inner-neg")
+
+  (test/spec-failed
+   'vector/c-collapsible7
+   '(let* ([ctc1 (vector/c (vector/c integer?))]
+           [ctc2 (vector/c (vector/c positive?))]
+           [v (contract
+               ctc1
+               (add-many-contracts 11 ctc2 (vector (vector 1)) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (vector-set! (vector-ref v 0) 0 1/2))
+   'neg)
+
+  (test/spec-failed
+      'vector/c-collapsible8
+   '(let* ([ctc1 (vector/c (vector/c integer?))]
+           [ctc2 (vector/c (vector/c positive?))]
+           [v (contract
+               ctc1
+               (add-many-contracts 11 ctc2 (vector (vector 1/2)) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (vector-ref (vector-ref v 0) 0))
+   'pos)
+
+  (test/spec-failed
+   'vector/c-collapsible9
+   '(let* ([ctc1 (vector/c (vector/c integer?))]
+           [ctc2 (vector/c (vector/c positive?))]
+           [v (contract
+               ctc1
+               (add-many-contracts 11 ctc2 (vector (vector -1)) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (vector-ref (vector-ref v 0) 0))
+   "inner-pos")
+
+  ;; tests for various first-order checks performed by vectors
+  (test/spec-failed
+   'vector/c-collapsible10
+   '(let* ([ctc [vector/c (vector/c integer?)]]
+           [v (contract
+               ctc
+               (add-many-contracts 11 ctc (vector (vector 1)) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (vector-set! v 0 'bad))
+   'neg)
+
+    (test/spec-failed
+     'vector/c-collapsible11
+     '(let* ([ctc (vector/c (vector/c integer? #:immutable #t))]
+             [v (contract
+                 ctc
+                 (add-many-contracts 11 ctc (vector (vector 1)) 'inner-pos 'inner-neg)
+                 'pos 'neg)])
+        (vector-ref v 0))
+     "inner-pos")
+
+  (test/spec-passed
+   'vector/c-impersonator
+   '(let* ([ctc (vector/c (make-contract #:late-neg-projection (lambda (b) (lambda (x n) 'foo))))]
+           [v (contract ctc (add-many-contracts 11 ctc (vector 1) 'inner-pos 'inner-neg) 'pos 'neg)])
+      (vector-ref v 0)))
+
+  (test/spec-failed
+   'vector/c-blame
+   '(let* ([ctc (vector/c (-> integer? integer?))]
+           [v (contract
+               ctc
+               (add-many-contracts 11 ctc (vector add1) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      ((vector-ref v 0) 1.5))
+   "neg")
+
+  (test/spec-failed
+   'vectorof-blame
+   '(let* ([ctc (vectorof (-> integer? integer?))]
+           [v (contract
+               ctc
+               (add-many-contracts 11 ctc (vector add1) 'inner-pos 'inner-neg)
+               'pos 'neg)])
+      ((vector-ref v 0) 1.5))
+   "neg")
+
+  ;; collapsible continuation marks
+
+  (contract-eval
+   '(define (make-has-collapsible-mark? b)
+      (flat-named-contract
+       'has-collapsible-mark?
+       (lambda (v)
+         (define marks (current-continuation-marks))
+         (define res (continuation-mark-set-first marks collapsible-contract-continuation-mark-key))
+         (set-box! b (or (unbox b) res))
+         #t))))
+
+  (test-true
+   'collapsible-mark-present
+   '(let* ([b (box #f)]
+           [ctc (vectorof (make-has-collapsible-mark? b))]
+           [v (add-many-contracts 12 ctc (vector 1))])
+      (vector-ref v 0)
+      (unbox b)))
+
+  (test/spec-passed/result
+   'collapsible-mark-absent
+   '(let* ([b (box #f)]
+           [ctc (vectorof (make-has-collapsible-mark? b))]
+           [v (contract ctc (vector 1) 'pos 'neg)])
+      (vector-ref v 0)
+      (unbox b))
+   #f
+   do-not-double-wrap)
+
+  (test/spec-failed
+   'vector/c-bailout
+   '(let* ([ctc1 (vector/c (vector/c integer?))]
+           [ctc2 (vector/c (-> integer?))]
+           [v (contract
+               ctc2
+               (add-many-contracts
+                11
+                ctc1
+                (vector (vector 1 2))
+                'inner-pos 'inner-neg)
+               'pos 'neg)])
+      (vector-ref v 0))
+   "inner-pos")
+
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;; Implementation tests
+  ;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (contract-eval '(require (submod racket/contract/private/vector-collapsible for-testing)))
+  (contract-eval '(require (submod racket/contract/private/collapsible-common for-testing)))
+  (contract-eval '(define (collapsible? val)
+                    (and (has-impersonator-prop:collapsible? val)
+                         (let ([prop (get-impersonator-prop:collapsible val #f)])
+                           (and (collapsible-wrapper-property? prop)
+                                (eq? val (collapsible-property-ref prop)))))))
+
+  ;; vectorof
+  (contract-eval
+   '(define (vectorof-has-num-contracts? v ref set)
+      (with-handlers ([exn:fail? (lambda (e) (exn-message e))])
+        (unless (has-impersonator-prop:collapsible? v)
+          (error "vectorof-has-num-contracts?: no collapsible-contract"))
+        ;; TODO: maybe should check that is a collapsible-wrapper-property ...
+        (define collapsible/c (collapsible-property-c-c (get-impersonator-prop:collapsible v)))
+        (define ref/c (collapsible-vector-ref-ctcs collapsible/c))
+        (define set/c (collapsible-vector-set-ctcs collapsible/c))
+        (unless (= (length (collapsible-leaf/c-proj-list ref/c)) ref)
+          (error "vectorof-has-num-contracts?: wrong number of ref projections"))
+        (unless (= (length (collapsible-leaf/c-proj-list set/c)) set)
+          (error "vectorof-has-num-contracts?: wrong number of set projections"))
+        (unless (= (length (collapsible-leaf/c-contract-list ref/c)) ref)
+          (error "vectorof-has-num-contracts?: wrong number of ref contracts"))
+        (unless (= (length (collapsible-leaf/c-contract-list set/c)) set)
+          (error "vectorof-has-num-contracts?: wrong number of set contracts"))
+        #t)))
+
+  (contract-eval
+   '(define (vector-can-combine? val ctc)
+      (define cv (contract ctc val 'p 'n))
+      (and (collapsible? val)
+           (collapsible? cv))))
+
+  ;; vector/c
+  (contract-eval
+   '(define (vector/c-has-num-contracts? v refs sets)
+      (with-handlers ([exn:fail? (lambda (e) (exn-message e))])
+        (unless (has-impersonator-prop:collapsible? v)
+          (error "vectorof-has-num-contracts?: no collapsible-contract"))
+        ;; TODO: maybe should check that is a collapsible-wrapper-property ...
+        (define collapsible/c (collapsible-property-c-c (get-impersonator-prop:collapsible v)))
+        (define ref-ctcs (collapsible-vector-ref-ctcs collapsible/c))
+        (define set-ctcs (collapsible-vector-set-ctcs collapsible/c))
+        (for ([ref (in-list refs)]
+              [ref/c (in-vector ref-ctcs)])
+          (unless (= (length (collapsible-leaf/c-proj-list ref/c)) ref)
+            (error "vector/c-has-num-contracts?: wrong number of ref projections"))
+          (unless (= (length (collapsible-leaf/c-contract-list ref/c)) ref)
+            (error "vector/c-has-num-contracts?: wrong number of ref contracts")))
+        (for ([set (in-list sets)]
+              [set/c (in-vector set-ctcs)])
+          (unless (= (length (collapsible-leaf/c-proj-list set/c)) set)
+            (error "vector/c-has-num-contracts?: wrong number of set projections"))
+          (unless (= (length (collapsible-leaf/c-contract-list set/c)) set)
+            (error "vector/c-has-num-contracts?: wrong number of set contracts")))
+        #t)))
+   
+  (contract-eval
+   '(define pos
+      (flat-named-contract
+       'pos
+       (lambda (x) (and (integer? x) (>= x 0))))))
+  
+  (test-true
+   'vecof-false-contracts
+   '(let* ([cv (add-many-contracts 11 (vectorof #f) (vector #f))])
+      (vectorof-has-num-contracts? cv 1 1)))
+
+  (test-true
+   'vec/c-false-contracts
+   '(let* ([cv (add-many-contracts 11 (vector/c #f) (vector #f))])
+      (vector/c-has-num-contracts? cv '(1) '(1))))
+
+  (test-true
+   'vecof-many-false-contracts
+   '(vectorof-has-num-contracts? (add-many-contracts 1000 (vectorof #f) (vector #f)) 1 1))
+
+  (test-true
+   'vec/c-many-false-contracts
+   '(vector/c-has-num-contracts? (add-many-contracts 1000 (vector/c #f) (vector #f)) '(1) '(1)))
+
+  (test-true
+   'vecof-num-contracts
+   '(let* ([v (add-many-contracts 11 (vectorof pos) (vector 1))])
+      (vectorof-has-num-contracts? v 1 1)))
+
+  (test-true
+   'vecof-num-contracts-different-ref-set
+   '(let* ([ctc1 (vectorof (>/c 0))]
+           [ctc2 (vectorof real?)]
+           [v1 (add-many-contracts 11 ctc1 (vector 1))]
+           [v (contract ctc2 (contract ctc2 v1 'pos 'neg) 'pos 'neg)])
+      (vectorof-has-num-contracts? v 1 2)))
+
+  (test-true
+   'vec/c-num-contracts
+   '(let* ([v (add-many-contracts 11 (vector/c pos pos) (vector 1 2))])
+      (vector/c-has-num-contracts? v '(1 1) '(1 1))))
+
+  (test-true
+   'vec/c-num-contracts-different-ref-set
+   '(let* ([ctc1 (vector/c (>/c 0) (>/c 0))]
+           [ctc2 (vector/c real? real?)]
+           [v1 (add-many-contracts 11 ctc1 (vector 1 2))]
+           [v (contract ctc2 (contract ctc2 v1 'pos 'neg) 'pos 'neg)])
+      (vector/c-has-num-contracts? v '(1 1) '(2 2))))
+
+  (test-true
+   'vec/c-num-contracts-different-ref-set-different-posns
+   '(let* ([ctc1 (vector/c (>/c 0) real?)]
+           [ctc2 (vector/c real? real?)]
+           [v1 (add-many-contracts 11 ctc1 (vector 1 2))]
+           [v (contract ctc2 (contract ctc2 v1 'pos 'neg) 'pos 'neg)])
+      (vector/c-has-num-contracts? v '(1 1) '(2 1))))
+
+   (test-true
+   'vec/c-more-ref-than-set
+   '(let* ([ctc2 (vector/c (>/c 0) real?)]
+           [ctc1 (vector/c real? real?)]
+           [v1 (add-many-contracts 11 ctc1 (vector 1 2))]
+           [v (contract ctc2 (contract ctc2 v1 'pos 'neg) 'pos 'neg)])
+      (vector/c-has-num-contracts? v '(2 1) '(1 1))))
+
+  ;; TODO: a couple more has-num-contracts? tests with one contract sandwiching another for more interesting contract
+  ;; merging
+
+  (test-true
+   'vecof-sandwich1
+   '(let* ([ctc1 (vectorof integer?)]
+           [ctc2 (vectorof real?)]
+           [v1 (add-many-contracts 11 ctc1 (vector 1))]
+           [v (contract ctc1 (contract ctc2 v1 'p 'n) 'p 'n)])
+      (vectorof-has-num-contracts? v 2 2)))
+
+  (test-true
+   'vec/c-sandwich1
+   '(let* ([ctc1 (vector/c integer?)]
+           [ctc2 (vector/c real?)]
+           [v1 (add-many-contracts 11 ctc1 (vector 1))]
+           [v (contract ctc1 (contract ctc2 v1 'p 'n) 'p 'n)])
+      (vector/c-has-num-contracts? v '(2) '(2))))
+
+
+  (test-true
+   'vecof-incompatible1
+   '(let* ([ctc1 (vectorof integer?)]
+           [ctc2 (vectorof string?)]
+           [v1 (add-many-contracts 11 ctc2 (vector 1))]
+           [v (contract ctc1 v1 'p 'n)])
+      (vectorof-has-num-contracts? v 2 2)))
+
+  (test-true
+   'vecof-incompatible2
+   '(let* ([ctc1 (vectorof integer?)]
+           [ctc2 (vectorof string?)]
+           [v1 (add-many-contracts 11 ctc1 (vector 1))]
+           [v (contract ctc2 v1 'p 'n)])
+      (vectorof-has-num-contracts? v 2 2)))
+
+  (test-true
+   'vec/c-incompatible1
+   '(let* ([ctc1 (vector/c integer?)]
+           [ctc2 (vector/c string?)]
+           [v1 (add-many-contracts 11 ctc2 (vector 1))]
+           [v (contract ctc1 v1 'p 'n)])
+      (vector/c-has-num-contracts? v '(2) '(2))))
+
+  (test-true
+   'vec/c-incompatible2
+   '(let* ([ctc1 (vector/c integer?)]
+           [ctc2 (vector/c string?)]
+           [v1 (add-many-contracts 11 ctc1 (vector 1))]
+           [v (contract ctc2 v1 'p 'n)])
+      (vector/c-has-num-contracts? v '(2) '(2))))
+
+  (test/spec-failed
+   'vecof-incompatible1-blame1
+   '(let* ([ctc1 (vectorof integer?)]
+           [ctc2 (vectorof string?)]
+           [v (contract ctc1 (add-many-contracts 11 ctc2 (vector 1) 'inner-pos 'inner-neg) 'pos 'neg)])
+      (vector-ref v 0))
+   "inner-pos")
+  (test/spec-failed
+   'vecof-incompatible1-blame2
+   '(let* ([ctc1 (vectorof integer?)]
+           [ctc2 (vectorof string?)]
+           [v (contract ctc1 (add-many-contracts 11 ctc2 (vector "foo") 'inner-pos 'inner-neg) 'pos 'neg)])
+      (vector-ref v 0))
+   'pos)
+  (test/spec-failed
+   'vecof-incompatible1-blame3
+   '(let* ([ctc1 (vectorof integer?)]
+           [ctc2 (vectorof string?)]
+           [v (contract ctc1 (add-many-contracts 11 ctc2 (vector 1) 'inner-pos 'inner-neg) 'pos 'neg)])
+      (vector-set! v 0 "foo"))
+   'neg)
+  (test/spec-failed
+   'vecof-incompatible1-blame4
+   '(let* ([ctc1 (vectorof integer?)]
+           [ctc2 (vectorof string?)]
+           [v (contract ctc1 (add-many-contracts 11 ctc2 (vector 1) 'inner-pos 'inner-neg) 'pos 'neg)])
+      (vector-set! v 0 2))
+   "inner-neg")
+
+  (test/spec-failed
+   'vec/c-incompatible1-blame1
+   '(let* ([ctc1 (vector/c integer?)]
+           [ctc2 (vector/c string?)]
+           [v (contract ctc1 (add-many-contracts 11 ctc2 (vector 1) 'inner-pos 'inner-neg) 'pos 'neg)])
+      (vector-ref v 0))
+   "inner-pos")
+  (test/spec-failed
+   'vec/c-incompatible1-blame2
+   '(let* ([ctc1 (vector/c integer?)]
+           [ctc2 (vector/c string?)]
+           [v (contract ctc1 (add-many-contracts 11 ctc2 (vector "foo") 'inner-pos 'inner-neg) 'pos 'neg)])
+      (vector-ref v 0))
+   'pos)
+  (test/spec-failed
+   'vec/c-incompatible1-blame3
+   '(let* ([ctc1 (vector/c integer?)]
+           [ctc2 (vector/c string?)]
+           [v (contract ctc1 (add-many-contracts 11 ctc2 (vector 1) 'inner-pos 'inner-neg) 'pos 'neg)])
+      (vector-set! v 0 "foo"))
+   'neg)
+  (test/spec-failed
+   'vec/c-incompatible1-blame4
+   '(let* ([ctc1 (vector/c integer?)]
+           [ctc2 (vector/c string?)]
+           [v (contract ctc1 (add-many-contracts 11 ctc2 (vector 1) 'inner-pos 'inner-neg) 'pos 'neg)])
+      (vector-set! v 0 2))
+   "inner-neg")
+
+  ;; can combine tests
+
+  (contract-eval
+   '(define imp-ctc1
+      (make-contract
+       #:late-neg-projection (lambda (blame) (lambda (val neg) val)))))
+
+  (contract-eval
+   '(define imp-ctc2
+      (make-contract
+       #:late-neg-projection (lambda (blame) (lambda (val neg) val)))))
+
+  (contract-eval
+   '(define chap-ctc
+      (make-chaperone-contract
+       #:late-neg-projection (lambda (blame) (lambda (val neg) val)))))
+
+  ;; vectorof combine
+  (test/spec-passed/result
+   'vectorof-can-combine-chaps
+   '(let* ([ctc1 (vectorof integer?)]
+           [ctc2 (vectorof real?)]
+           [v (add-many-contracts 11 ctc1 (vector 1) 'pos 'neg)])
+      (vector-can-combine? v ctc2))
+   #t)
+
+  (test/spec-passed/result
+   'vectorof-can-combine-imps
+   '(let* ([ctc1 (vectorof imp-ctc1)]
+           [ctc2 (vectorof imp-ctc2)]
+           [v (add-many-contracts 11 ctc1 (vector 1) 'pos 'neg)])
+      (vector-can-combine? v ctc2))
+   #t)
+
+  (test/spec-passed/result
+   'vectorof-cant-mix-chap-imp
+   '(let* ([ctc1 (vectorof chap-ctc)]
+           [ctc2 (vectorof imp-ctc1)]
+           [v (add-many-contracts 11 ctc1 (vector 1) 'pos 'neg)])
+      (vector-can-combine? v ctc2))
+   #f)
+
+  (test/spec-passed/result
+   'vectorof-cant-mix-imp-chap
+   '(let* ([ctc1 (vectorof imp-ctc1)]
+           [ctc2 (vectorof chap-ctc)]
+           [v (add-many-contracts 11 ctc1 (vector 1) 'pos 'neg)])
+      (vector-can-combine? v ctc2))
+   #f)
+
+  (test/spec-passed/result
+   'vectorof-cant-merge-if-chaperoned-in-se-mode
+   '(let* ([ctc (vectorof integer?)]
+           [v1 (add-many-contracts 11 ctc (vector 1) 'pos 'neg)]
+           [v (chaperone-vector v1 #f #f)])
+      (vector-can-combine? v ctc))
+   #f)
+
+  ;; vector/c combine
+  (test/spec-passed/result
+   'vector/c-can-combine-chaps
+   '(let* ([ctc1 (vector/c integer?)]
+           [ctc2 (vector/c real?)]
+           [v (add-many-contracts 11 ctc1 (vector 1) 'pos 'neg)])
+      (vector-can-combine? v ctc2))
+   #t)
+
+  (test/spec-passed/result
+   'vector/c-can-combine-imps
+   '(let* ([ctc1 (vector/c imp-ctc1)]
+           [ctc2 (vector/c imp-ctc2)]
+           [v (add-many-contracts 11 ctc1 (vector 1) 'pos 'neg)])
+      (vector-can-combine? v ctc2))
+   #t)
+
+  (test/spec-passed/result
+   'vector/c-cant-mix-chap-imp
+   '(let* ([ctc1 (vector/c chap-ctc)]
+           [ctc2 (vector/c imp-ctc1)]
+           [v (add-many-contracts 11 ctc1 (vector 1) 'pos 'neg)])
+      (vector-can-combine? v ctc2))
+   #f)
+
+  (test/spec-passed/result
+   'vector/c-cant-mix-imp-chap
+   '(let* ([ctc1 (vector/c imp-ctc1)]
+           [ctc2 (vector/c chap-ctc)]
+           [v (add-many-contracts 11 ctc1 (vector 1) 'pos 'neg)])
+      (vector-can-combine? v ctc2))
+   #f)
+
+  (test/spec-passed/result
+   'vector/c-cant-merge-if-chaperoned-in-se-mode
+   '(let* ([ctc (vector/c integer?)]
+           [v1 (add-many-contracts 11 ctc (contract ctc (vector 1) 'pos 'neg) 'pos 'neg)]
+           [v (chaperone-vector v1 #f #f)])
+      (vector-can-combine? v ctc))
+   #f)
+
+
+  (contract-eval
+   '(define many-layers
+      (contract (vectorof even?)
+                (chaperone-vector
+                 (add-many-contracts
+                  11
+                  (vectorof exact-integer?)
+                  (contract (vectorof positive?)
+                            (vector 2)
+                            'pos1 'neg1)
+                  'pos2 'neg2)
+                 #f
+                 #f)
+                'pos3 'neg3)))
+
+  (test/spec-failed
+   'many-layers-neg1
+   '(vector-set! many-layers 0 0)
+   "neg1")
+  (test/spec-failed
+   'many-layers-neg2
+   '(vector-set! many-layers 0 2.0)
+   "neg2")
+  (test/spec-failed
+   'many-layers-neg3
+   '(vector-set! many-layers 0 1)
+   "neg3")
+
+  (contract-eval
+   '(define many-layers/c
+      (contract (vector/c even?)
+                (chaperone-vector
+                 (add-many-contracts
+                  11
+                  (vector/c exact-integer?)
+                  (contract (vector/c positive?)
+                            (vector 2)
+                            'pos1 'neg1)
+                  'pos2 'neg2)
+                 #f
+                 #f)
+                'pos3 'neg3)))
+  
+  (test/spec-failed
+   'many-layers/c-neg1
+   '(vector-set! many-layers/c 0 0)
+   "neg1")
+  (test/spec-failed
+   'many-layers/c-neg2
+   '(vector-set! many-layers/c 0 2.0)
+   "neg2")
+  (test/spec-failed
+   'many-layers/c-neg3
+   '(vector-set! many-layers/c 0 1)
+   "neg3")
+
+  ;; Vector Sorting Tests
+  ;; Make sure that if we sort a vector of vectors
+  ;; that must ref each element at least n times that the
+  ;; contained vectors do not build up contracts
+  
+  (contract-eval
+   '(define (my-sort vec)
+      (define length (vector-length vec))
+      (for ([i (in-range length)])
+        (for ([j (in-range i length)])
+          (define vi (vector-ref vec i))
+          (define vj (vector-ref vec j))
+          (when (< (vector-ref vj 0) (vector-ref vi 0))
+            (vector-set! vec i vj)
+            (vector-set! vec j vi))))))
+
+  (contract-eval
+   '(define unsorted (vector
+                      (vector 10)
+                      (vector 9)
+                      (vector 8)
+                      (vector 7)
+                      (vector 6)
+                      (vector 5)
+                      (vector 4)
+                      (vector 3)
+                      (vector 2)
+                      (vector 1))))
+
+  (contract-eval
+   '(define unsorted+contracted
+      (add-many-contracts 11 (vectorof (vectorof integer?))
+                          unsorted
+                          'pos 'neg)))
+
+  (test-true
+   'vecof-sorting
+   '(let ()
+      (my-sort unsorted+contracted)
+      (for/and ([v (in-vector unsorted+contracted)])
+        (vectorof-has-num-contracts? v 1 1))))
+
+  (contract-eval
+   '(define unsorted2 (vector
+                      (vector 10)
+                      (vector 9)
+                      (vector 8)
+                      (vector 7)
+                      (vector 6)
+                      (vector 5)
+                      (vector 4)
+                      (vector 3)
+                      (vector 2)
+                      (vector 1))))
+
+  (contract-eval
+   '(define unsorted+contracted-vector/c
+      (add-many-contracts 11
+                          (vector/c (vector/c integer?)
+                                    (vector/c integer?)
+                                    (vector/c integer?)
+                                    (vector/c integer?)
+                                    (vector/c integer?)
+                                    (vector/c integer?)
+                                    (vector/c integer?)
+                                    (vector/c integer?)
+                                    (vector/c integer?)
+                                    (vector/c integer?))
+                          unsorted2
+                          'pos 'neg)))
+
+  (test-true
+   'vecof-sorting
+   '(let ()
+      (my-sort unsorted+contracted-vector/c)
+      (for/and ([v (in-vector unsorted+contracted-vector/c)])
+        (vector/c-has-num-contracts? v '(1) '(1)))))
+
+  ;; bail out and switching bugs
+
+  (contract-eval '(require racket/class))
+
+  (test/spec-passed
+   'object/c-passing-vecof
+   '(let* ([grid/c (vectorof (vectorof (object/c)))]
+           [grid (contract
+                  grid/c
+                  (add-many-contracts
+                   11
+                   grid/c
+                   (vector (vector (new object%)))
+                   'inner-pos 'inner-neg)
+                  'pos 'neg)])
+      (vector-ref (vector-ref grid 0) 0)))
+
+  (test/spec-failed
+   'object/c-failing-vecof
+   '(let* ([v (contract (vectorof integer?) (vector 1) 'orig-p 'orig-n)]
+           [grid/c (vectorof (vectorof (object/c)))]
+           [grid (contract
+                  grid/c
+                  (add-many-contracts
+                   11
+                   grid/c
+                   (vector v)
+                   'inner-pos 'inner-neg)
+                  'pos 'neg)])
+      (vector-ref (vector-ref grid 0) 0))
+   "inner-pos")
+
+  (test/spec-passed
+   'object/c-passing-vec/c
+   '(let* ([grid/c (vector/c (vector/c (object/c)))]
+           [grid (contract
+                  grid/c
+                  (add-many-contracts
+                   11
+                   grid/c
+                   (vector (vector (new object%)))
+                   'inner-pos 'inner-neg)
+                  'pos 'neg)])
+      (vector-ref (vector-ref grid 0) 0)))
+
+  (test/spec-failed
+   'object/c-failing-vecof
+   '(let* ([v (contract (vector/c integer?) (vector 1) 'orig-p 'orig-n)]
+           [grid/c (vector/c (vector/c (object/c)))]
+           [grid (contract
+                  grid/c
+                  (add-many-contracts
+                   11
+                   grid/c
+                   (vector v)
+                   'inner-pos 'inner-neg)
+                  'pos 'neg)])
+      (vector-ref (vector-ref grid 0) 0))
+   "inner-pos")
+
+  (contract-eval
+   '(define (double-wrapped? x)
+      (define prop (get-impersonator-prop:collapsible x #f))
+      (and
+       (collapsible-wrapper-property? prop)
+       (and (has-impersonator-prop:collapsible?
+             (collapsible-wrapper-property-checking-wrapper prop))
+            ;; this is annoying because of how unsafe-chaperone-vector ...
+            ;; work in relation to impersonator-properties
+            (collapsible-wrapper-property?
+             (get-impersonator-prop:collapsible
+              (collapsible-wrapper-property-checking-wrapper prop)
+              #f))))))
+
+  (test-false
+   'dont-multi-wrap
+   '(let* ([ctc (vectorof (vectorof integer?))]
+           [v (contract ctc (add-many-contracts 11 ctc (vector (vector 1)) 'ip 'in) 'p 'n)]
+           [v2 (contract (vectorof any/c) v 'p2 'n2)])
+      (double-wrapped? v2)))
+
+  ;; blame and higher-order leaves
+  (test/spec-failed
+   'vectorof+box/c-different-blame
+   '(let* ([ctc1 (vectorof (box/c integer?))]
+           [v (contract ctc1
+                        (add-many-contracts
+                         11
+                         ctc1
+                         (vector (box 1))
+                         'inner-pos 'inner-neg)
+                        'pos 'neg)])
+      (set-box! (vector-ref v 0) 1.1))
+   "neg")
+
+  (test/spec-failed
+   'vectorof+box/c-same-blame
+   '(let* ([ctc1 (vectorof (box/c real? any/c))]
+           [ctc2 (vectorof (box/c (>/c 0) any/c))]
+           [v (contract ctc1 (add-many-contracts 11 ctc2 (vector (box 1))
+                                       'pos 'neg) 'pos 'neg)])
+      (set-box! (vector-ref v 0) -1))
+   "neg")
+
+  (test/spec-failed
+   'vectorof+box/c-same-blame2
+   '(let* ([ctc1 (vectorof (box/c real? any/c))]
+           [ctc2 (vectorof (box/c (>/c 0) any/c))]
+           [v (contract ctc2 (add-many-contracts 11 ctc1 (vector (box 1))
+                                       'pos 'neg) 'pos 'neg)])
+      (set-box! (vector-ref v 0) -1))
+   "neg")
+
+  (test/spec-failed
+   'vectorof+box
+   '(let* ([ctc (vectorof (box/c integer?))]
+           [v (contract ctc (add-many-contracts 11 ctc (vector (box 1)) 'inner-pos 'inner-neg) 'pos 'neg)])
+      (set-box! (vector-ref v 0) 1.5))
+   "neg")
+
+  (test/spec-failed
+   'vector/c+box
+   '(let* ([ctc (vector/c (box/c integer?))]
+           [v (contract ctc (add-many-contracts 11 ctc (vector (box 1)) 'inner-pos 'inner-neg) 'pos 'neg)])
+      (set-box! (vector-ref v 0) 1.5))
+   "neg")
+
+  ;; Tests for nested merging of vectorof and vector/c contracts
+  (test/spec-passed/result
+   'vecof+vec/c1
+   '(let* ([ctc1 (vectorof integer?)]
+           [ctc2 (vector/c integer? integer?)]
+           [v (contract ctc1 (add-many-contracts 11 ctc2 (vector 1 2) 'ip 'in) 'p 'n)])
+      (and (vector/c-has-num-contracts? v '(1 1) '(1 1))
+           (collapsible? v)))
+   #t)
+
+  (test/spec-passed/result
+   'vecof+vec/c2
+   '(let* ([ctc2 (vectorof integer?)]
+           [ctc1 (vector/c integer? integer?)]
+           [v (contract ctc1 (add-many-contracts 11 ctc2 (vector 1 2) 'ip 'in) 'p 'n)])
+      (and (vector/c-has-num-contracts? v '(1 1) '(1 1))
+           (collapsible? v)))
+   #t)
+
+  (test/spec-failed
+   'vecof+vec/c3
+   '(let* ([ctc1 (vectorof integer?)]
+           [ctc2 (vector/c integer? integer?)]
+           [v (contract ctc1 (add-many-contracts 11 ctc2 (vector 1 2 3) 'ip 'in) 'p 'n)])
+      v)
+   "ip")
+
+  (test/spec-failed
+   'vecof+vec/c4
+   '(let* ([ctc2 (vectorof integer?)]
+           [ctc1 (vector/c integer? integer?)]
+           [v (contract ctc1 (add-many-contracts 11 ctc2 (vector 1 2 3) 'ip 'in) 'p 'n)])
+      v)
+   "p")
+
+  (test/spec-passed/result
+   'vecof+vec/c5
+   '(let* ([ctc2 (vectorof (vector/c integer?))]
+           [ctc1 (vector/c (vector/c integer?))]
+           [v (contract ctc1 (add-many-contracts 11 ctc2 (vector (vector 1)) 'ip 'in) 'p 'n)]
+           [v1 (vector-ref v 0)])
+      (and (vector/c-has-num-contracts? v1 '(1) '(1))
+           (collapsible? v)
+           (collapsible? v1)))
+   #t)
+
+  (test/spec-passed/result
+   'vecof+vec/c6
+   '(let* ([ctc1 (vectorof (vector/c integer?))]
+           [ctc2 (vector/c (vector/c integer?))]
+           [v (contract ctc1 (add-many-contracts 11 ctc2 (vector (vector 1)) 'ip 'in) 'p 'n)]
+           [v1 (vector-ref v 0)])
+      (and (vector/c-has-num-contracts? v1 '(1) '(1))
+           (collapsible? v)
+           (collapsible? v1)))
+   #t)
+
+  (test/spec-passed/result
+   'vecof+vec/c7
+   '(let* ([ctc1 (vectorof (vector/c integer?))]
+           [ctc2 (vector/c (vectorof integer?))]
+           [v (contract ctc1 (add-many-contracts 11 ctc2 (vector (vector 1)) 'ip 'in) 'p 'n)]
+           [v1 (vector-ref v 0)])
+      (and (vector/c-has-num-contracts? v1 '(1) '(1))
+           (collapsible? v)
+           (collapsible? v1)))
+   #t)
+
+  (test/spec-passed/result
+   'vecof+vec/c8
+   '(let* ([ctc2 (vectorof (vector/c integer?))]
+           [ctc1 (vector/c (vectorof integer?))]
+           [v (contract ctc1 (add-many-contracts 11 ctc2 (vector (vector 1)) 'ip 'in) 'p 'n)]
+           [v1 (vector-ref v 0)])
+      (and (vector/c-has-num-contracts? v1 '(1) '(1))
+           (collapsible? v)
+           (collapsible? v1)))
+   #t)
+
+  (test/spec-failed
+   'vecof+vec/c9
+   '(let* ([ctc1 (vectorof (vector/c (vectorof integer?)))]
+           [ctc2 (vector/c (vectorof (vector/c integer?)))]
+           [v
+            (contract
+             ctc1
+             (add-many-contracts 11 ctc2 (vector (vector (vector 1 2))) 'ip 'in)
+             'p 'n)]
+           [v0 (vector-ref v 0)])
+      (vector-ref v0 0))
+   "ip")
+
+  (test/spec-failed
+   'vecof+vec/c10
+   '(let* ([ctc1 (vectorof (vector/c (vectorof integer?)))]
+           [ctc2 (vector/c (vectorof (vector/c integer?)))]
+           [v
+            (contract
+             ctc2
+             (add-many-contracts 11 ctc1 (vector (vector (vector 1 2))) 'ip 'in)
+             'p 'n)]
+           [v0 (vector-ref v 0)])
+      (vector-ref v0 0))
+   "p")
+
+  (test/spec-failed
+   'vecof+vec/c11
+   '(let* ([ctc1 (vectorof (vector/c (vectorof integer?)))]
+           [ctc2 (vector/c (vectorof (vector/c integer?)))]
+           [v
+            (contract
+             ctc1
+             (add-many-contracts 11 ctc2 (vector (vector (vector 1))) 'ip 'in)
+             'p 'n)]
+           [v0 (vector-ref v 0)])
+      (vector-set! v0 0 (vector 2 3)))
+   "in")
+
+   (test/spec-failed
+   'vecof+vec/c12
+   '(let* ([ctc1 (vectorof (vector/c (vectorof integer?)))]
+           [ctc2 (vector/c (vectorof (vector/c integer?)))]
+           [v
+            (contract
+             ctc2
+             (add-many-contracts 11 ctc1 (vector (vector (vector 1))) 'ip 'in)
+             'p 'n)]
+           [v0 (vector-ref v 0)])
+      (vector-set! v0 0 (vector 2 3)))
+   "n")
+
+  (test/spec-passed/result
+   'vecof+vec/c13
+   '(let* ([ctc1 (vectorof (vector/c (vectorof integer?)))]
+           [ctc2 (vector/c (vectorof (vector/c integer?)))]
+           [v
+            (contract
+             ctc1
+             (add-many-contracts 11 ctc2 (vector (vector (vector 1))) 'ip 'in)
+             'p 'n)]
+           [v0 (vector-ref v 0)]
+           [v1 (vector-ref v0 0)])
+      (and (vector/c-has-num-contracts? v1 '(1) '(1))
+           (collapsible? v)
+           (collapsible? v0)
+           (collapsible? v1)))
+   #t)
+
+  (test-true
+   'vecof+vec/c14
+   '(let* ([ctc1 (vectorof (vector/c (>/c 0) (>/c 0)))]
+           [ctc2 (vector/c (vectorof real?))]
+           [v1 (add-many-contracts 11 ctc1 (vector (vector 1 2)) 'ip 'in)]
+           [v2 (add-many-contracts 11  ctc2 v1 'p 'n)]
+           [v (vector-ref v2 0)])
+      (vector/c-has-num-contracts? v '(1 1) '(2 2))))
+
+  (test-true
+   'vecof+vec/c15
+   '(let* ([ctc1 (vectorof (vector/c real? real?))]
+           [ctc2 (vector/c (vectorof (>/c 0)))]
+           [v1 (add-many-contracts 11 ctc1 (vector (vector 1 2)) 'ip 'in)]
+           [v2 (add-many-contracts 11 ctc2 v1 'p 'n)]
+           [v (vector-ref v2 0)])
+      (vector/c-has-num-contracts? v '(2 2) '(1 1))))
+
+  (test/spec-passed
+   'vecof+chap+non-c-c
+   '(let ()
+      (define ctc (vectorof (-> integer?)))
+      (define v (contract ctc (add-many-contracts 11 ctc (vector (lambda () 1)) 'ip 'in) 'p 'n))
+      (define my/c
+        (make-chaperone-contract
+         #:late-neg-projection
+         (lambda (blame)
+           (lambda (val neg)
+             (define full-blame (blame-add-missing-party blame neg))
+             (chaperone-procedure
+              val
+              #f
+              impersonator-prop:contracted my/c
+              impersonator-prop:blame full-blame)))))
+      (define f (contract my/c (lambda () 23) 'pf 'nf))
+      (vector-set! v 0 f)))
+
+
+  (contract-eval
+   '(define my->/c
+      (make-chaperone-contract
+       #:late-neg-projection
+       (lambda (blame)
+         (lambda (val neg)
+           (define full-blame (blame-add-missing-party blame neg))
+           (chaperone-procedure
+            val
+            (lambda (arg)
+              (unless (integer? arg)
+                (raise-blame-error (blame-swap full-blame) arg "bad arg"))
+              (values
+               (lambda (res)
+                 (unless (integer? res)
+                   (raise-blame-error full-blame res "bad res"))
+                 res)
+               arg))
+            impersonator-prop:contracted my->/c
+            impersonator-prop:blame full-blame))))))
+
+   (test/spec-passed
+    'vecof+chap+non-c-c-ok
+    '(let ()
+       (define ctc (vectorof (-> integer? integer?)))
+       (define v (contract ctc (add-many-contracts 11 ctc (vector (lambda (x) 1)) 'ip 'in) 'p 'n))
+       (define f (contract my->/c (lambda (x) 23) 'pf 'nf))
+       (vector-set! v 0 f)
+       ((vector-ref v 0) 1)))
+
+   (test/spec-failed
+    'vecof+chap+non-c-c-blame-neg
+    '(let ()
+       (define ctc (vectorof (-> integer? integer?)))
+       (define v (contract ctc (add-many-contracts 11 ctc (vector (lambda (x) 1)) 'ip 'in) 'p 'n))
+       (define f (contract my->/c (lambda (x) 23) 'pf 'nf))
+       (vector-set! v 0 f)
+       ((vector-ref v 0) 1.1))
+    "n")
+
+   (test/spec-failed
+    'vecof+chap+non-c-c-blame-pos
+    '(let ()
+       (define ctc (vectorof (-> integer? integer?)))
+       (define v (contract ctc (add-many-contracts 11 ctc (vector (lambda (x) 1)) 'ip 'in) 'p 'n))
+       (define f (contract my->/c (lambda (x) 2.3) 'pf 'nf))
+       (vector-set! v 0 f)
+       ((vector-ref v 0) 1))
+    "pf")
+
+  (test/spec-passed
+   'vecof+->-insert-contracted-non-c-c
+   '(let ()
+      (define ctc (vectorof (-> integer?)))
+      (define v (contract ctc (add-many-contracts 11 ctc (vector (lambda () 1)) 'ip 'in) 'p 'n))
+      (define f (contract
+                 (case-> (-> integer?)
+                         (-> (values integer? integer?)))
+                 (lambda () 2)
+                 'fp 'fn))
+      (vector-set! v 0 f)))
+
+  (test/spec-passed
+   'vec/c+->-insert-contracted-non-c-c
+   '(let ()
+      (define ctc (vector/c (-> integer?)))
+      (define v (contract ctc (add-many-contracts 11 ctc (vector (lambda () 1)) 'ip 'in) 'p 'n))
+      (define f (contract
+                 (case-> (-> integer?)
+                         (-> (values integer? integer?)))
+                 (lambda () 2)
+                 'fp 'fn))
+      (vector-set! v 0 f)))
+
+  (test/spec-failed
+   'vecof+->-insert-contracted-non-c-c-fail-blame-pos
+   '(let ()
+      (define ctc (vectorof (-> integer?)))
+      (define v (contract ctc (add-many-contracts 11 ctc (vector (lambda () 1)) 'ip 'in) 'p 'n))
+      (define f (contract
+                 (case-> (-> integer?)
+                         (-> (values integer? integer?)))
+                 (lambda () 'bad)
+                 'fp 'fn))
+      (vector-set! v 0 f)
+      ((vector-ref v 0)))
+   "fp")
+
+  (test/spec-failed
+   'vecof+->-insert-contracted-non-c-c-fail-blame-neg
+   '(let ()
+      (define ctc (vectorof (-> integer? integer?)))
+      (define v (contract ctc (add-many-contracts 11 ctc (vector (lambda (x) 1)) 'ip 'in) 'p 'n))
+      (define f (contract
+                 (case-> (-> integer? integer?)
+                         (-> integer? (values integer? integer?)))
+                 (lambda (x) 3)
+                 'fp 'fn))
+      (vector-set! v 0 f)
+      ((vector-ref v 0) 1.2))
+   "n")
+
+  (test/spec-failed
+   'vector-symbol-multi-pos1
+   '(let* ([ctc1 (vectorof (vectorof integer?))]
+           [ctc2 (vectorof symbol?)]
+           [v (contract
+               ctc2
+               (add-many-contracts
+                11
+                ctc1 (vector (vector 1)) 'inner-pos 'inner-neg) 'pos 'neg)])
+      (vector-ref v 0))
+   "pos")
+
+  (test/spec-failed
+   'vector-symbol-multi-pos2
+   '(let* ([ctc1 (vectorof (vectorof integer?))]
+           [ctc2 (vectorof symbol?)]
+           [v (contract ctc2 (add-many-contracts 11 ctc1 (vector 'foo) 'inner-pos 'inner-neg) 'pos 'neg)])
+      (vector-ref v 0))
+   "inner-pos")
+
+  (test/spec-failed
+   'vector-symbol-multi-neg1
+   '(let* ([ctc1 (vectorof symbol?)]
+           [ctc2 (vectorof (vectorof integer?))]
+           [v (contract
+               ctc2
+               (add-many-contracts 11 ctc1 (vector 'dont-care) 'inner-pos 'inner-neg) 'pos 'neg)])
+      (vector-set! v 0 (vector 1)))
+   "inner-neg")
+
+  (test/spec-failed
+   'vector-symbol-multi-neg2
+   '(let* ([ctc1 (vectorof symbol?)]
+           [ctc2 (vectorof (vectorof integer?))]
+           [v (contract
+               ctc2
+               (add-many-contracts 11 ctc1 (vector 'dont-care) 'inner-pos 'inner-neg) 'pos 'neg)])
+      (vector-set! v 0 'foo))
+   "neg")
+
+  (test/spec-failed
+   'collapse-keep-different-blame
+   '(let ()
+      (define blame-holder (contract (vectorof (vectorof positive?)) (vector (vector 1)) 'pos #f))
+      (define blame-holder2 (contract (vectorof (vectorof negative?)) (vector (vector 1)) 'pos #f))
+      (define pos-blame1 (value-blame blame-holder))
+      (define pos-blame2 (value-blame blame-holder2))
+      (define ctc (vectorof (vectorof positive?)))
+      (define ctc2 (vectorof (vectorof negative?)))
+      (define lnp (get/build-late-neg-projection ctc))
+      (define lnp2 (get/build-late-neg-projection ctc2))
+      (define ctc+blame (lnp pos-blame1))
+      (define ctc+blame2 (lnp2 pos-blame2))
+      (define v (vector (vector -1)))
+
+      (define cv1 (for/fold ([cv v]) ([_ (in-range 3)]) (ctc+blame cv 'neg1)))
+      (define cv2 (for/fold ([cv cv1]) ([_ (in-range 3)]) (ctc+blame2 cv 'neg2)))
+      (define cv3 (for/fold ([cv cv2]) ([_ (in-range 3)]) (ctc+blame cv 'neg3)))
+      (define cv4 (for/fold ([cv cv3]) ([_ (in-range 2)]) (ctc+blame2 cv 'neg4)))
+
+      (define iv (vector-ref cv4 0))
+      (vector-set! iv 0 -1))
+   "neg3")
+
+  (test/spec-failed
+   'collapse-keep-higher-order
+   '(let ()
+      (define blame-holder (contract (vectorof (vectorof positive?)) (vector (vector 1)) 'pos #f))
+      (define pos-blame1 (value-blame blame-holder))
+      (define ctc (vectorof (vectorof positive?)))
+      (define lnp (get/build-late-neg-projection ctc))
+      (define ctc+blame (lnp pos-blame1))
+      (define v (vector (vector 1)))
+
+      (define cv1 (for/fold ([cv v]) ([_ (in-range 4)]) (ctc+blame cv 'neg1)))
+      (define cv2 (for/fold ([cv cv1]) ([_ (in-range 4)]) (ctc+blame cv 'neg2)))
+      (define cv3 (for/fold ([cv cv2]) ([_ (in-range 3)]) (ctc+blame cv 'neg1)))
+
+      (define iv (vector-ref cv3 0))
+      (vector-set! iv 0 -1))
+   "neg1")
+  )
diff --git a/pkgs/racket-test/tests/racket/contract/context.rkt b/pkgs/racket-test/tests/racket/contract/context.rkt
index 2f2c788705..355e3df22e 100644
--- a/pkgs/racket-test/tests/racket/contract/context.rkt
+++ b/pkgs/racket-test/tests/racket/contract/context.rkt
@@ -72,6 +72,16 @@
                             'pos
                             'neg)
                   0 1))
+
+  (context-test '("the 1st argument of")
+                '((contract (-> boolean? integer? integer?)
+                            (contract (-> boolean? integer? integer?)
+                                      (λ (x y) x)
+                                      'pos
+                                      'neg)
+                            'pos
+                            'neg)
+                  0 1))
   
   (context-test '("the cdr of" "the 1st argument of")
                 '((contract (-> (cons/c integer? boolean?) integer? integer?)
@@ -344,6 +354,59 @@
                              'neg)
                    2)
                   0))
+
+  (context-test '("an element of" "the 2nd element of")
+                '(vector-ref
+                  (vector-ref
+                   (let ([ctc (vector/c (vectorof real?)
+                                        (vectorof number?)
+                                        (vectorof boolean?))])
+                     (contract
+                      ctc
+                      (contract
+                       ctc
+                       (vector (vector 1) (vector 1) (vector 1))
+                       'pos
+                       'neg)
+                      'pos
+                      'neg))
+                   2)
+                  0))
+
+  (context-test
+   '("the 1st argument of" "an element of" "the range of" "the 2nd element of")
+   '(let* ([ctc (vector/c any/c any/c (-> any/c (vectorof (-> string? any/c))))]
+           [v (vector 'any1
+                      'any2
+                      (λ (_) (vector (λ (s) s))))]
+           [cv (contract ctc (contract ctc v 'pos 'neg) 'pos 'neg)])
+      ((vector-ref ((vector-ref cv 2) 'any3) 0) 'not-a-string)))
+
+  (context-test
+   '("the range of" "an element of" "the range of" "the 2nd element of")
+   '(let* ([ctc (vector/c any/c any/c (-> any/c (vectorof (-> string? string?))))]
+           [v (vector 'any1
+                      'any2
+                      (λ (_) (vector (λ (s) s))))]
+           [cv (contract ctc (contract ctc v 'pos 'neg) 'pos 'neg)])
+      (vector-set! cv 2 (λ (_) (vector (λ (_) 'not-a-string))))
+      ((vector-ref ((vector-ref cv 2) 'any3) 0) "a string")))
+
+  (context-test '("the 1st element of" "an element of")
+                '(vector-ref
+                  (vector-ref
+                   (let ([ctc (vectorof (vector/c integer? boolean?))])
+                     (contract
+                      ctc
+                      (contract
+                       ctc
+                       (vector (vector 1 2) (vector 2 3))
+                       'pos
+                       'neg)
+                      'pos
+                      'neg))
+                   0)
+                  1))
   
   (context-test '("the 0th element of")
                 '(vector-ref (contract (vector/c integer?)
@@ -508,6 +571,50 @@
                 '(contract (and/c integer? positive?)
                            5.9
                            'pos 'neg))
+
+  (context-test
+   '("the x argument of" "an element of")
+   '(let ()
+      (define (contract* n c v pos neg)
+        (for/fold ([cv v])
+                  ([_ (in-range n)])
+          (contract c cv pos neg)))
+      (define c1 (vectorof (->i ([x integer?]) [_ integer?])))
+      (define c2 (vectorof (->i ([y (not/c string?)]) [_ any/c])))
+      (define vec
+        (contract
+         c1
+         (contract
+          c2
+          (contract* 11 c1 (vector (λ (x) x)) 'p 'n)
+          'p
+          'n)
+         'p
+         'n))
+      (define f (vector-ref vec 0))
+      (f "bad")))
+
+  (context-test
+   '("the x argument of" "an element of")
+   '(let ()
+      (define (contract* n c v pos neg)
+        (for/fold ([cv v])
+                  ([_ (in-range n)])
+          (contract c cv pos neg)))
+      (define c1 (vectorof (->i ([x integer?]) [_ integer?])))
+      (define c2 (vectorof (->i ([y (not/c string?)]) [_ any/c])))
+      (define vec
+        (contract
+         c1
+         (contract
+          c2
+          (contract c1 (vector (λ (x) x)) 'p 'n)
+          'p
+          'n)
+         'p
+         'n))
+      (define f (vector-ref vec 0))
+      (f "bad")))
   
   (let* ([blame-pos (contract-eval '(make-blame (srcloc #f #f #f #f #f)
                                                 #f
@@ -520,4 +627,4 @@
     (ctest "promised: ~s\n  produced: ~e" blame-fmt->-string ,blame-pos '(expected: "~s" given: "~e"))
     (ctest "expected: ~s\n  given: ~e" blame-fmt->-string ,blame-neg '(expected: "~s" given: "~e"))
     (ctest "promised ~s produced ~e" blame-fmt->-string ,blame-pos '(expected "~s" given "~e"))
-    (ctest "expected ~s given ~e" blame-fmt->-string ,blame-neg '(expected "~s" given "~e"))))
\ No newline at end of file
+    (ctest "expected ~s given ~e" blame-fmt->-string ,blame-neg '(expected "~s" given "~e"))))
diff --git a/pkgs/racket-test/tests/racket/contract/contract-out.rkt b/pkgs/racket-test/tests/racket/contract/contract-out.rkt
index 2a57383134..a124c7a626 100644
--- a/pkgs/racket-test/tests/racket/contract/contract-out.rkt
+++ b/pkgs/racket-test/tests/racket/contract/contract-out.rkt
@@ -1664,8 +1664,7 @@
      (and (exn:fail:contract:blame? x)
           ;; ensure there is context information
           (regexp-match? #rx"in: the 1st argument of" (exn-message x))
-          (regexp-match? #rx"blaming: [^\n]*contract7-n" (exn-message x)))))
-  
+          (regexp-match? #rx"blaming: [^\n]*contract7-n" (exn-message x)))))  
   
   (contract-error-test
    're-providing
diff --git a/pkgs/racket-test/tests/racket/contract/make-contract.rkt b/pkgs/racket-test/tests/racket/contract/make-contract.rkt
index 38101e5a08..0af6f061c0 100644
--- a/pkgs/racket-test/tests/racket/contract/make-contract.rkt
+++ b/pkgs/racket-test/tests/racket/contract/make-contract.rkt
@@ -246,6 +246,48 @@
       (list-contract? (odd-length-list-of-integers)))
    #t)
 
+  (test/pos-blame
+   'build-chaperone-contract-property-s-e1
+   '(let ()
+      (struct s-e-late-neg-none ()
+        #:property prop:chaperone-contract
+        (build-chaperone-contract-property
+         #:collapsible-late-neg-projection
+         (λ (ctc)
+           (λ (blame)
+             (values
+              (λ (val neg-party)
+                (raise-blame-error blame val "bad"))
+              #f)))
+         #:name (λ (x) 'the-name)
+         #:first-order (λ (c) (λ (x) #t))
+         #:stronger (λ (x y) #f)))
+
+      (((contract-projection (s-e-late-neg-none))
+        (make-blame (srcloc #f #f #f #f #f) 5 (λ () 'the-name) 'pos 'neg #t))
+       5)))
+
+  (test/pos-blame
+   'build-chaperone-contract-property-s-e2
+   '(let ()
+      (struct s-e-late-neg-none ()
+        #:property prop:chaperone-contract
+        (build-chaperone-contract-property
+         #:collapsible-late-neg-projection
+         (λ (ctc)
+           (λ (blame)
+             (values
+              (λ (val neg-party)
+                (raise-blame-error blame val "bad"))
+              #f)))
+         #:name (λ (x) 'the-name)
+         #:first-order (λ (c) (λ (x) #t))
+         #:stronger (λ (x y) #f)))
+
+      (((contract-projection (listof (s-e-late-neg-none)))
+        (make-blame (srcloc #f #f #f #f #f) 5 (λ () 'the-name) 'pos 'neg #t))
+       (list 1 2 3))))
+
   (contract-eval
    '(define prop:late-neg-proj:bad-prime-box-list/c
       (let* ([prime? (λ (n)
diff --git a/pkgs/racket-test/tests/racket/contract/object-contract.rkt b/pkgs/racket-test/tests/racket/contract/object-contract.rkt
index 7e0314fc68..3744170c6a 100644
--- a/pkgs/racket-test/tests/racket/contract/object-contract.rkt
+++ b/pkgs/racket-test/tests/racket/contract/object-contract.rkt
@@ -1464,19 +1464,20 @@
 
 (let ([c% (parameterize ([current-inspector (make-inspector)])
             (contract-eval '(class object% (super-new))))])
-  (test (list c% #f)
+  (test #:test-case-name 'object-info
+        (list c% #f)
         'object-info
         (contract-eval
          `(call-with-values
            (lambda () (object-info (contract (object-contract) (new ,c%) 'pos 'neg)))
            list))))
 
-;; object->vector tests
 (let* ([obj
         (parameterize ([current-inspector (make-inspector)])
           (contract-eval '(new (class object% (field [x 1] [y 2]) (super-new)))))]
        [vec (contract-eval `(object->vector ,obj))])
-  (test vec
+  (test #:test-case-name 'object->vector
+        vec
         (contract-eval 'object->vector)
         (contract-eval
          `(contract (object-contract (field x integer?) (field y integer?))
diff --git a/pkgs/racket-test/tests/racket/contract/object.rkt b/pkgs/racket-test/tests/racket/contract/object.rkt
index e5464acdc6..6f9d23185b 100644
--- a/pkgs/racket-test/tests/racket/contract/object.rkt
+++ b/pkgs/racket-test/tests/racket/contract/object.rkt
@@ -422,7 +422,8 @@
                   'pos 'neg))
       log)
 
-   '(c b a) '(c c b b a a))
+   '(c b a)
+   '(c c c c c c c c c c c b b b b b b b b b b b a a a a a a a a a a a))
 
   ;; this tests the situation where the double-wrapping avoidance
   ;; kicks in. The second part of the result, '(a b b a a), indicates
diff --git a/pkgs/racket-test/tests/racket/contract/opt-c.rkt b/pkgs/racket-test/tests/racket/contract/opt-c.rkt
index f3c739466d..b4b70c4f8e 100644
--- a/pkgs/racket-test/tests/racket/contract/opt-c.rkt
+++ b/pkgs/racket-test/tests/racket/contract/opt-c.rkt
@@ -313,4 +313,24 @@ so that propagation occurs.
   (ctest #t couple? (make-couple 1 2))
   (ctest #t couple? (contract (couple/dc [hd any/c] [tl (hd) any/c]) (make-couple 1 2) 'pos 'neg))
   (ctest #f couple? 1)
-  (ctest #f couple? #f))
+  (ctest #f couple? #f)
+
+  (test/spec-passed/result
+   "chaperone-contracts-stay-chaperones"
+   '(let ([ctc (-> integer?)]
+          [opt-ctc (opt/c (-> integer?))])
+      (and (chaperone-contract? ctc)
+           (not (impersonator-contract? ctc))
+           (chaperone-contract? opt-ctc)
+           (not (impersonator-contract? ctc))))
+   #t)
+
+  (test/spec-passed/result
+   "impersonators-stay-impersonators"
+   '(let ([ctc (->i () [_ any/c])]
+          [opt-ctc (opt/c (->i () [_ any/c]))])
+      (and (impersonator-contract? ctc)
+           (not (chaperone-contract? ctc))
+           (impersonator-contract? opt-ctc)
+           (not (chaperone-contract? opt-ctc))))
+   #t))
diff --git a/pkgs/racket-test/tests/racket/contract/or-and.rkt b/pkgs/racket-test/tests/racket/contract/or-and.rkt
index a408abaebe..80553d65e0 100644
--- a/pkgs/racket-test/tests/racket/contract/or-and.rkt
+++ b/pkgs/racket-test/tests/racket/contract/or-and.rkt
@@ -103,7 +103,21 @@
                 'neg)
       x)
    '(1 2)
-   '(1 2 1 2)) ; result if contract is applied twice
+   do-not-double-wrap)
+
+  (test/spec-passed/result
+   'or/c-ordering-double-wrap
+   '(let ([x '()])
+      (contract (or/c (lambda (y) (set! x (cons 2 x)) #f) (lambda (y) (set! x (cons 1 x)) #t))
+                (contract
+                 (or/c (lambda (y) (set! x (cons 2 x)) #f) (lambda (y) (set! x (cons 1 x)) #t))
+                 'anything
+                 'pos 'neg)
+                'pos
+                'neg)
+      x)
+   '(1 2 1 2)
+   do-not-double-wrap)
   
   (test/spec-passed/result
    'or/c-ordering2
@@ -114,7 +128,21 @@
                 'neg)
       x)
    '(2)
-   '(2 2)) ; result if contract is applied twice
+   do-not-double-wrap)
+
+  (test/spec-passed/result
+   'or/c-ordering2-double-wrap
+   '(let ([x '()])
+      (contract (or/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t))
+                (contract
+                 (or/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t))
+                 'anything
+                 'pos 'neg)
+                'pos
+                'neg)
+      x)
+   '(2 2)
+   do-not-double-wrap)
   
   (test/spec-passed
    'or/c-hmm
@@ -188,7 +216,21 @@
                 'neg)
       x)
    '(1 2)
-   '(1 2 1 2)) ; result if contract is applied twice
+   do-not-double-wrap)
+
+  (test/spec-passed/result
+   'and/c-ordering-double-wrap
+   '(let ([x '()])
+      (contract (and/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t))
+                (contract
+                 (and/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t))
+                 'anything
+                 'pos 'neg)
+                'pos
+                'neg)
+      x)
+   '(1 2 1 2)
+   do-not-double-wrap)
   
   (test/spec-passed/result
    'ho-and/c-ordering
@@ -203,7 +245,28 @@
        1)
       (reverse x))
    '(3 1 2 4)
-   '(3 1 3 1 2 4 2 4)) ; result if contract is applied twice
+   do-not-double-wrap)
+
+  (test/spec-passed/result
+   'ho-and/c-ordering-double-wrap
+   '(let ([x '()])
+      ((contract (and/c (-> (lambda (y) (set! x (cons 1 x)) #t)
+                            (lambda (y) (set! x (cons 2 x)) #t))
+                        (-> (lambda (y) (set! x (cons 3 x)) #t)
+                            (lambda (y) (set! x (cons 4 x)) #t)))
+                 (contract
+                  (and/c (-> (lambda (y) (set! x (cons 1 x)) #t)
+                             (lambda (y) (set! x (cons 2 x)) #t))
+                         (-> (lambda (y) (set! x (cons 3 x)) #t)
+                             (lambda (y) (set! x (cons 4 x)) #t)))
+                  (λ (x) x)
+                  'pos 'neg)
+                 'pos
+                 'neg)
+       1)
+      (reverse x))
+      '(3 1 3 1 2 4 2 4)
+      do-not-double-wrap)
   
   (test/spec-passed/result
    'and/c-isnt
@@ -344,7 +407,22 @@
                 'neg)
       x)
    '(1 2)
-   '(1 2 1 2)) ; result if contract is applied twice
+   do-not-double-wrap)
+
+  (test/spec-passed/result
+   'first-or/c-ordering-double-wrap
+   '(let ([x '()])
+      (contract (first-or/c (lambda (y) (set! x (cons 2 x)) #f) (lambda (y) (set! x (cons 1 x)) #t))
+                (contract
+                 (first-or/c (lambda (y) (set! x (cons 2 x)) #f) (lambda (y) (set! x (cons 1 x)) #t))
+                 'anything
+                 'pos
+                 'neg)
+                'pos
+                'neg)
+      x)
+   '(1 2 1 2)
+   do-not-double-wrap)
   
   (test/spec-passed/result
    'first-or/c-ordering2
@@ -355,7 +433,21 @@
                 'neg)
       x)
    '(2)
-   '(2 2)) ; result if contract is applied twice
+   do-not-double-wrap)
+
+  (test/spec-passed/result
+   'first-or/c-ordering2-double-wrap
+   '(let ([x '()])
+      (contract (first-or/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t))
+                (contract
+                 (first-or/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t))
+                 'anything
+                 'pos 'neg)
+                'pos
+                'neg)
+      x)
+   '(2 2)
+   do-not-double-wrap)
   
   (test/spec-passed
    'first-or/c-hmm
diff --git a/pkgs/racket-test/tests/racket/contract/prof.rkt b/pkgs/racket-test/tests/racket/contract/prof.rkt
index 7617af3ec1..b35ea770e3 100644
--- a/pkgs/racket-test/tests/racket/contract/prof.rkt
+++ b/pkgs/racket-test/tests/racket/contract/prof.rkt
@@ -396,7 +396,7 @@
    '(contract (vector/c pos-blame? #:flat? #t) #(1) 'pos 'neg))
 
   (test/spec-passed
-   'contract-marks42
+   'contract-marks42b
    '((vector-ref (contract (vector/c (-> pos-blame? neg-blame?)) (vector values)
                            'pos 'neg)
                  0)
diff --git a/pkgs/racket-test/tests/racket/contract/recursive-contract.rkt b/pkgs/racket-test/tests/racket/contract/recursive-contract.rkt
index 7b71cd2a63..4d16f757c3 100644
--- a/pkgs/racket-test/tests/racket/contract/recursive-contract.rkt
+++ b/pkgs/racket-test/tests/racket/contract/recursive-contract.rkt
@@ -138,4 +138,5 @@
       ;; with the old implementation it is more like 20 seconds
       ;; on my laptop and about .3 seconds with the new one
       (< (- cpu gc) 5000))
-   #t))
+   #t
+   do-not-double-wrap))
diff --git a/pkgs/racket-test/tests/racket/contract/struct-dc.rkt b/pkgs/racket-test/tests/racket/contract/struct-dc.rkt
index 41b40bc3f5..a9df126b54 100644
--- a/pkgs/racket-test/tests/racket/contract/struct-dc.rkt
+++ b/pkgs/racket-test/tests/racket/contract/struct-dc.rkt
@@ -213,7 +213,9 @@
         (struct gds dx ())
         (define gd (contract (struct/c gds (vectorof any/c)) (gds (vector 1)) 'pos 'neg))
         (vector-ref (d-vec gd) 0)))
-   1)
+   1
+   ;; wrapping 11 times is too many for this test case, so skip the multi-wrap test
+   do-not-double-wrap)
   
   (test/spec-passed
    'struct/c-simple-contract-accessor 
@@ -1005,7 +1007,7 @@
    do-not-double-wrap)
   
   (test/spec-passed/result
-   'struct/dc-new42
+   'struct/dc-new42-1
    '(let ()
       (struct s (a [b #:mutable]))
       (define α (new-∀/c 'α))
@@ -1013,10 +1015,11 @@
                       (λ (x) (s 11 x))
                       'pos
                       'neg) 1)))
-   1)
+   1
+   do-not-double-wrap)
   
   (test/spec-passed
-   'struct/dc-new42
+   'struct/dc-new42-2
    '(let ()
       (struct s (a [b #:mutable]))
       (contract (struct/dc s [a (-> integer? integer?)] [b (new-∀/c 'α)])
diff --git a/pkgs/racket-test/tests/racket/contract/test-util.rkt b/pkgs/racket-test/tests/racket/contract/test-util.rkt
index 2a8751ccf2..b7c44bcac0 100644
--- a/pkgs/racket-test/tests/racket/contract/test-util.rkt
+++ b/pkgs/racket-test/tests/racket/contract/test-util.rkt
@@ -9,6 +9,7 @@
          test/neg-blame
          test/well-formed
          test ctest ctest/rewrite
+         test-true test-false
          
          current-contract-namespace
          make-basic-contract-namespace
@@ -23,14 +24,17 @@
          contract-expand
          
          rewrite-to-add-opt/c
-         rewrite-to-double-wrap
+         rewrite-to-multi-wrap
          do-not-double-wrap
+         contract-rewrite-tests-to-skip
          
          test-cases failures)
 
 (define test-cases 0)
 (define failures 0)
 
+(define contract-rewrite-tests-to-skip (make-parameter '()))
+
 (provide new-test-case new-failure)
 (define (new-test-case name)
   ;(printf "running test ~a\n" name)
@@ -101,6 +105,7 @@
   (parameterize ([current-namespace n])
     (namespace-require 'racket/contract/base)
     (namespace-require '(only racket/contract/private/blame exn:fail:contract:blame?))
+    (namespace-require '(only racket/contract/private/collapsible-common COLLAPSIBLE-LIMIT))
     (for ([addon (in-list addons)])
       (namespace-require addon)))
   n)
@@ -159,7 +164,9 @@
   (test #t
         name
         (contract-eval #:test-case-name name
-                       `(with-handlers ((exn:fail? (λ (x) (and (,exn-ok? x) #t)))) ,exp))))
+                       `(with-handlers ((exn:fail? (λ (x) (and (,exn-ok? x) #t))))
+                          ,exp
+                          "NO EXN RAISED"))))
 
 (define (contract-syntax-error-test name exp [reg #rx""])
   (test #t
@@ -207,7 +214,7 @@
                   ,(wrapper expression k)
                   'no-exn-raised)))))
   (rewrite-test rewrite-to-add-opt/c   "rewrite-to-add-opt/c")
-  (rewrite-test rewrite-to-double-wrap "rewrite-to-double-wrap"))
+  (rewrite-test rewrite-to-multi-wrap "rewrite-to-double-wrap"))
 
 (define (test/spec-passed/result name expression result [double-wrapped-result result])
   (parameterize ([compile-enforce-module-constants #f])
@@ -224,7 +231,7 @@
            ',(wrapper expression k)))))
     (rewrite-test rewrite-to-add-opt/c   "rewrite-to-add-opt/c")
     (unless (eq? double-wrapped-result do-not-double-wrap)
-      (rewrite-test rewrite-to-double-wrap "rewrite-to-double-wrap" double-wrapped-result))
+      (rewrite-test rewrite-to-multi-wrap "rewrite-to-double-wrap" double-wrapped-result))
 
     (let ([new-expression (rewrite-out expression)])
       (when new-expression
@@ -237,6 +244,10 @@
            eval
            ',new-expression))))))
 
+;; convenient shortcuts
+(define (test-true name expression)  (test/spec-passed/result name expression #t))
+(define (test-false name expression) (test/spec-passed/result name expression #f))
+
 ;; rewrites `provide/contract' to use `contract-out'
 (define (rewrite-out orig-exp)
   (define rewrote? #f)
@@ -327,16 +338,15 @@
   (rewrite (lambda (ctc val parties loop)
              `(contract (opt/c ,(loop ctc)) ,(loop val) ,@(map loop parties)))))
 
-;; rewrites `contract` to double-wrap. To test space-efficient wrappers.
-(define rewrite-to-double-wrap
+;; rewrites `contract` to double-wrap. To test collapsible wrappers.
+(define rewrite-to-multi-wrap
   (rewrite (lambda (ctc val parties loop)
              (define new-ctc (loop ctc))
              (define new-parties (map loop parties))
-             `(contract ,new-ctc
-                        (contract ,(loop ctc)
-                                  ,(loop val)
-                                  ,@new-parties)
-                        ,@new-parties))))
+             `(let ([the-ctc ,new-ctc])
+                (for/fold ([the-val ,(loop val)])
+                          ([i (in-range (add1 COLLAPSIBLE-LIMIT))])
+                  (contract the-ctc the-val ,@new-parties))))))
 (define do-not-double-wrap (gensym)) ; recognized by some test forms
 
 ;; blame : (or/c 'pos 'neg string?)
@@ -360,19 +370,20 @@
        (and (exn:fail:contract:blame? exn)
             (,has-proper-blame? (exn-message exn))))))
   (define (rewrite-test wrapper wrapper-name short-wrapper-name)
-    (let/ec k
-      (let ([rewritten (wrapper expression k)])
-        (contract-eval
-         #:test-case-name (format "~a ~a" name wrapper-name)
-         `(,test-an-error
-           ',(string->symbol (format "~a+~a" name short-wrapper-name))
-           (lambda () ,rewritten)
-           ',rewritten
-           (lambda (exn)
-             (and (exn:fail:contract:blame? exn)
-                  (,has-proper-blame? (exn-message exn)))))))))
-  (rewrite-test rewrite-to-add-opt/c   "rewrite-to-add-opt/c"   "opt/c")
-  (rewrite-test rewrite-to-double-wrap "rewrite-to-double-wrap" "double"))
+    (unless (member short-wrapper-name (contract-rewrite-tests-to-skip))
+      (let/ec k
+        (let ([rewritten (wrapper expression k)])
+          (contract-eval
+           #:test-case-name (format "~a ~a" name wrapper-name)
+           `(,test-an-error
+             ',(string->symbol (format "~a+~a" name short-wrapper-name))
+             (lambda () ,rewritten)
+             ',rewritten
+             (lambda (exn)
+               (and (exn:fail:contract:blame? exn)
+                    (,has-proper-blame? (exn-message exn))))))))))
+  (rewrite-test rewrite-to-add-opt/c  "rewrite-to-add-opt/c"   "opt/c")
+  (rewrite-test rewrite-to-multi-wrap "rewrite-to-double-wrap" "double"))
 
 (define (test/pos-blame name expression) (test/spec-failed name expression 'pos))
 (define (test/neg-blame name expression) (test/spec-failed name expression 'neg))
@@ -392,7 +403,7 @@
                         ',name*
                         ,(wrapper 'expression k)))))
            (rewrite-test rewrite-to-add-opt/c   'opt-name)
-           (rewrite-test rewrite-to-double-wrap 'double-name)))]))
+           (rewrite-test rewrite-to-multi-wrap 'double-name)))]))
 
 (define (test/well-formed stx)
   (contract-eval
@@ -427,4 +438,4 @@
                eval
                '(begin ,rewritten (void)))))))
   (rewrite-test rewrite-to-add-opt/c   "opt/c")
-  (rewrite-test rewrite-to-double-wrap "double"))
+  (rewrite-test rewrite-to-multi-wrap "double"))
diff --git a/pkgs/racket-test/tests/racket/contract/vector.rkt b/pkgs/racket-test/tests/racket/contract/vector.rkt
index 2e9b3b7d19..f38e342db6 100644
--- a/pkgs/racket-test/tests/racket/contract/vector.rkt
+++ b/pkgs/racket-test/tests/racket/contract/vector.rkt
@@ -1,5 +1,6 @@
 #lang racket/base
 (require "test-util.rkt")
+(require (only-in racket/contract/private/collapsible-common COLLAPSIBLE-LIMIT))
 (parameterize ([current-contract-namespace
                 (make-basic-contract-namespace
                  'racket/contract/combinator)])
@@ -87,41 +88,43 @@
               (vector-immutable 11)
               'pos 'neg))
 
-  (test/pos-blame
-   'vectorof13
-   '(let ()
-      (define N 40)
-      (define cv
-        (contract (for/fold ([c (-> integer? integer?)])
-                            ([i (in-range N)])
-                    (vectorof c))
-                  (for/fold ([v 'not-a-procedure])
-                            ([i (in-range N)])
-                    (vector v))
-                  'pos 'neg))
-      (let loop ([cv cv])
-        (loop (vector-ref cv 0)))))
+  (parameterize ([contract-rewrite-tests-to-skip '("double")])
+    (test/pos-blame
+     'vectorof13
+     '(let ()
+        (define N 40)
+        (define cv
+          (contract (for/fold ([c (-> integer? integer?)])
+                              ([i (in-range N)])
+                      (vectorof c))
+                    (for/fold ([v 'not-a-procedure])
+                              ([i (in-range N)])
+                      (vector v))
+                    'pos 'neg))
+        (let loop ([cv cv])
+          (loop (vector-ref cv 0))))))
 
-  (test/neg-blame
-   'vectorof14
-   '(let ()
-      (define N 40)
-      (define cv
-        (contract (for/fold ([c (-> integer? integer?)])
-                            ([i (in-range N)])
-                    (vectorof c))
-                  (for/fold ([v add1])
-                            ([i (in-range N)])
-                    (vector v))
-                  'pos 'neg))
-      (let loop ([cv cv]
-                 [i N])
-        (cond
-          [(= i 1)
-           (vector-set! cv 0 'not-a-procedure)]
-          [else
-           (loop (vector-ref cv 0)
-                 (- i 1))]))))
+  (parameterize ([contract-rewrite-tests-to-skip '("double")])
+    (test/neg-blame
+     'vectorof14
+     '(let ()
+        (define N 40)
+        (define cv
+          (contract (for/fold ([c (-> integer? integer?)])
+                              ([i (in-range N)])
+                      (vectorof c))
+                    (for/fold ([v add1])
+                              ([i (in-range N)])
+                      (vector v))
+                    'pos 'neg))
+        (let loop ([cv cv]
+                   [i N])
+          (cond
+            [(= i 1)
+             (vector-set! cv 0 'not-a-procedure)]
+            [else
+             (loop (vector-ref cv 0)
+                   (- i 1))])))))
   
   (test/spec-passed
    'vector/c1
@@ -163,56 +166,59 @@
       (vector-set! (contract (vector/c integer?) v 'pos 'neg)
                    0 #f)))
 
-  (test/pos-blame
-   'vector/c7
-   '(let ()
-      (define N 40)
-      (define cv
-        (contract (for/fold ([c (-> integer? integer?)])
-                            ([i (in-range N)])
-                    (vector/c c))
-                  (for/fold ([v 'not-a-procedure])
-                            ([i (in-range N)])
-                    (vector v))
-                  'pos 'neg))
-      (let loop ([cv cv])
-        (loop (vector-ref cv 0)))))
+  (parameterize ([contract-rewrite-tests-to-skip '("double")])
+    (test/pos-blame
+     'vector/c7
+     '(let ()
+        (define N 40)
+        (define cv
+          (contract (for/fold ([c (-> integer? integer?)])
+                              ([i (in-range N)])
+                      (vector/c c))
+                    (for/fold ([v 'not-a-procedure])
+                              ([i (in-range N)])
+                      (vector v))
+                    'pos 'neg))
+        (let loop ([cv cv])
+          (loop (vector-ref cv 0))))))
 
-  (test/pos-blame
-   'vector/c8
-   '(let ()
-      (define N 40)
-      (define cv
-        (contract (for/fold ([c (-> integer? integer?)])
-                            ([i (in-range N)])
-                    (vector/c c))
-                  (for/fold ([v 'not-a-procedure])
-                            ([i (in-range N)])
-                    (vector-immutable v))
-                  'pos 'neg))
-      (let loop ([cv cv])
-        (loop (vector-ref cv 0)))))
+  (parameterize ([contract-rewrite-tests-to-skip '("double")])
+    (test/pos-blame
+     'vector/c8
+     '(let ()
+        (define N 40)
+        (define cv
+          (contract (for/fold ([c (-> integer? integer?)])
+                              ([i (in-range N)])
+                      (vector/c c))
+                    (for/fold ([v 'not-a-procedure])
+                              ([i (in-range N)])
+                      (vector-immutable v))
+                    'pos 'neg))
+        (let loop ([cv cv])
+          (loop (vector-ref cv 0))))))
 
-  (test/neg-blame
-   'vector/c9
-   '(let ()
-      (define N 40)
-      (define cv
-        (contract (for/fold ([c (-> integer? integer?)])
-                            ([i (in-range N)])
-                    (vector/c c))
-                  (for/fold ([v add1])
-                            ([i (in-range N)])
-                    (vector v))
-                  'pos 'neg))
-      (let loop ([cv cv]
-                 [i N])
-        (cond
-          [(= i 1)
-           (vector-set! cv 0 'not-a-procedure)]
-          [else
-           (loop (vector-ref cv 0)
-                 (- i 1))]))))
+  (parameterize ([contract-rewrite-tests-to-skip '("double")])
+    (test/neg-blame
+     'vector/c9
+     '(let ()
+        (define N 40)
+        (define cv
+          (contract (for/fold ([c (-> integer? integer?)])
+                              ([i (in-range N)])
+                      (vector/c c))
+                    (for/fold ([v add1])
+                              ([i (in-range N)])
+                      (vector v))
+                    'pos 'neg))
+        (let loop ([cv cv]
+                   [i N])
+          (cond
+            [(= i 1)
+             (vector-set! cv 0 'not-a-procedure)]
+            [else
+             (loop (vector-ref cv 0)
+                   (- i 1))])))))
   
   (test/pos-blame
    'vector/c7
@@ -234,7 +240,7 @@
                           'pos 'neg)
                 0)
    1
-   2)
+   (add1 COLLAPSIBLE-LIMIT))
 
   (test/spec-passed/result
    'vectorof-eager
diff --git a/racket/collects/racket/contract/base.rkt b/racket/collects/racket/contract/base.rkt
index 2b612049da..dd7baec78a 100644
--- a/racket/collects/racket/contract/base.rkt
+++ b/racket/collects/racket/contract/base.rkt
@@ -123,7 +123,7 @@
  value-blame
  contract-continuation-mark-key
  list-contract?
- 
+  
  ;; from private/case-arrow.rkt
  case->
 
diff --git a/racket/collects/racket/contract/collapsible.rkt b/racket/collects/racket/contract/collapsible.rkt
new file mode 100644
index 0000000000..32649c3be0
--- /dev/null
+++ b/racket/collects/racket/contract/collapsible.rkt
@@ -0,0 +1,28 @@
+#lang racket/base
+(require "private/collapsible-common.rkt"
+         (submod "private/collapsible-common.rkt" properties)
+         (only-in "private/guts.rkt"
+                  get/build-collapsible-late-neg-projection
+                  collapsible-contract-continuation-mark-key
+                  with-collapsible-contract-continuation-mark))
+
+(provide 
+ ;; collapsible functions and structures
+ (struct-out collapsible-ho/c)
+ (struct-out collapsible-leaf/c)
+ (struct-out collapsible-property)
+ (struct-out collapsible-count-property)
+ (struct-out collapsible-wrapper-property)
+ build-collapsible-leaf
+ prop:collapsible-contract
+ collapsible-contract-property?
+ build-collapsible-contract-property
+ collapsible-contract?
+ merge
+ collapsible-guard
+ impersonator-prop:collapsible
+ has-impersonator-prop:collapsible?
+ get-impersonator-prop:collapsible
+ get/build-collapsible-late-neg-projection
+ collapsible-contract-continuation-mark-key
+ with-collapsible-contract-continuation-mark)
diff --git a/racket/collects/racket/contract/combinator.rkt b/racket/collects/racket/contract/combinator.rkt
index 9936f3b4f5..d71593cd22 100644
--- a/racket/collects/racket/contract/combinator.rkt
+++ b/racket/collects/racket/contract/combinator.rkt
@@ -53,7 +53,7 @@
  contract-stronger?
  contract-equivalent?
  list-contract?
- 
+  
  contract-first-order
  contract-first-order-passes?
  
@@ -74,7 +74,7 @@
  
  contract-continuation-mark-key
  with-contract-continuation-mark
- 
+
  (struct-out wrapped-extra-arg-arrow)
  contract-custom-write-property-proc
  (rename-out [contract-custom-write-property-proc custom-write-property-proc])
@@ -123,6 +123,7 @@
          (λ (#:name [name 'anonymous-chaperone-contract]
                     #:first-order [first-order (λ (x) #t)]
                     #:late-neg-projection [late-neg-projection #f]
+                    #:collapsible-late-neg-projection [collapsible-late-neg-projection #f]
                     #:val-first-projection [val-first-projection #f]
                     #:projection [projection #f]
                     #:stronger [stronger #f]
@@ -133,6 +134,9 @@
             #:first-order first-order
             #:late-neg-projection
             (maybe-add-wrapper add-late-neg-chaperone-check late-neg-projection)
+            #:collapsible-late-neg-projection
+            (maybe-add-wrapper add-collapsible-late-neg-chaperone-check
+                               collapsible-late-neg-projection)
             #:val-first-projection
             (maybe-add-wrapper add-val-first-chaperone-check val-first-projection)
             #:projection
@@ -149,6 +153,7 @@
              #:first-order [get-first-order (λ (c) (λ (x) #t))]
              #:val-first-projection [val-first-proj #f]
              #:late-neg-projection [late-neg-proj #f]
+             #:collapsible-late-neg-projection [collapsible-late-neg-proj #f]
              #:projection [get-projection #f]
              #:stronger [stronger #f]
              #:equivalent [equivalent #f]
@@ -162,6 +167,8 @@
        (maybe-add-wrapper add-prop-val-first-chaperone-check val-first-proj)
        #:late-neg-projection
        (maybe-add-wrapper add-prop-late-neg-chaperone-check late-neg-proj)
+       #:collapsible-late-neg-projection
+       (maybe-add-wrapper add-prop-collapsible-late-neg-chaperone-check collapsible-late-neg-proj)
        #:projection
        (maybe-add-wrapper add-prop-chaperone-check get-projection)
        #:stronger stronger
@@ -171,6 +178,20 @@
        #:list-contract? is-list-contract?))
     build-chaperone-contract-property))
 
+(define (add-prop-collapsible-late-neg-chaperone-check get-collapsible-late-neg)
+  (λ (c)
+    (add-collapsible-late-neg-chaperone-check (get-collapsible-late-neg c))))
+
+(define (add-collapsible-late-neg-chaperone-check accepts-blame)
+  (λ (b)
+    (define-values (accepts-val-and-np collapsible-ctc) (accepts-blame b))
+    (values
+     (λ (x neg-party)
+       (check-and-signal x
+                         (accepts-val-and-np x neg-party)
+                         'make-chaperone-contract::collapsible-late-neg-projection))
+     collapsible-ctc)))
+
 (define (add-prop-late-neg-chaperone-check get-late-neg)
   (λ (c)
     (add-late-neg-chaperone-check (get-late-neg c))))
@@ -221,6 +242,7 @@
          (λ (#:name [name 'anonymous-chaperone-contract]
                     #:first-order [first-order (λ (x) #t)]
                     #:late-neg-projection [late-neg-projection #f]
+                    #:collapsible-late-neg-projection [collapsible-late-neg-projection #f]
                     #:val-first-projection [val-first-projection #f]
                     #:projection [projection #f]
                     #:stronger [stronger #f]
@@ -230,6 +252,8 @@
             #:name name
             #:first-order first-order
             #:late-neg-projection (force-late-neg-eq late-neg-projection)
+            #:collapsible-late-neg-projection
+            (force-collapsible-late-neg-eq collapsible-late-neg-projection)
             #:val-first-projection (force-val-first-eq val-first-projection)
             #:projection (force-projection-eq projection)
             #:stronger stronger
@@ -242,6 +266,7 @@
          (λ (#:name [name (λ (c) 'anonymous-chaperone-contract)]
                     #:first-order [first-order (λ (c) (λ (x) #t))]
                     #:late-neg-projection [late-neg-projection #f]
+                    #:collapsible-late-neg-projection [collapsible-late-neg-projection #f]
                     #:val-first-projection [val-first-projection #f]
                     #:projection [projection #f]
                     #:stronger [stronger #f]
@@ -253,6 +278,9 @@
             #:first-order first-order
             #:late-neg-projection
             (and late-neg-projection (λ (c) (force-late-neg-eq (late-neg-projection c))))
+            #:collapsible-late-neg-projection
+            (and collapsible-late-neg-projection
+                 (λ (c) (force-collapsible-late-neg-eq (collapsible-late-neg-projection c))))
             #:val-first-projection
             (and val-first-projection (λ (c) (force-val-first-eq (val-first-projection c))))
             #:projection
@@ -271,6 +299,15 @@
            (accepts-val-and-np x neg-party)
            x))))
 
+(define (force-collapsible-late-neg-eq accepts-blame)
+  (and accepts-blame
+       (λ (b)
+         (define-values (accepts-val-and-np collapsible-ctc) (accepts-blame b))
+         (values
+          (λ (x neg-party)
+            (accepts-val-and-np x neg-party))
+          collapsible-ctc))))
+
 (define (force-val-first-eq vfp)
   (and vfp
        (λ (b)
diff --git a/racket/collects/racket/contract/private/and.rkt b/racket/collects/racket/contract/private/and.rkt
index f7aa7a0fd0..a3551169ad 100644
--- a/racket/collects/racket/contract/private/and.rkt
+++ b/racket/collects/racket/contract/private/and.rkt
@@ -152,8 +152,8 @@
    #:name and-name
    #:first-order and-first-order
    #:stronger and-stronger?
-   #:equivalent and-equivalent?
-   #:generate and/c-generate?))
+   #:generate and/c-generate?
+   #:equivalent and-equivalent?))
 (define-struct (chaperone-and/c base-and/c) ()
   #:property prop:custom-write custom-write-property-proc
   #:property prop:chaperone-contract
@@ -162,8 +162,8 @@
    #:name and-name
    #:first-order and-first-order
    #:stronger and-stronger?
-   #:equivalent and-equivalent?
-   #:generate and/c-generate?))
+   #:generate and/c-generate?
+   #:equivalent and-equivalent?))
 (define-struct (impersonator-and/c base-and/c) ()
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
@@ -172,8 +172,8 @@
    #:name and-name
    #:first-order and-first-order
    #:stronger and-stronger?
-   #:equivalent and-equivalent?
-   #:generate and/c-generate?))
+   #:generate and/c-generate?
+   #:equivalent and-equivalent?))
 
 (define-syntax (and/c stx)
   (syntax-case stx (pair? listof)
@@ -359,8 +359,8 @@
    #:name integer-in-name
    #:first-order integer-in-first-order
    #:stronger integer-in-stronger
-   #:equivalent integer-in-equivalent
-   #:generate integer-in-generate))
+   #:generate integer-in-generate
+   #:equivalent integer-in-equivalent))
 
 (struct renamed-integer-in integer-in-ctc (name)
   #:property prop:flat-contract
@@ -389,4 +389,4 @@
 (set-some-basic-integer-in-contracts! renamed-integer-in
                                       (integer-in #f #f)
                                       (integer-in 0 #f)
-                                      (integer-in 1 #f))
\ No newline at end of file
+                                      (integer-in 1 #f))
diff --git a/racket/collects/racket/contract/private/arr-i-parse.rkt b/racket/collects/racket/contract/private/arr-i-parse.rkt
index d071398e0a..e69fa3d349 100644
--- a/racket/collects/racket/contract/private/arr-i-parse.rkt
+++ b/racket/collects/racket/contract/private/arr-i-parse.rkt
@@ -19,7 +19,7 @@ code does the parsing and validation of the syntax.
 
 |#
 
-;; istx-is-chaperone-contract? : boolean?
+;; is-chaperone-contract? : boolean?
 ;; args : (listof arg?)
 ;; rst  : (or/c #f arg/res?)
 ;; pre  : (listof pre/post?)
@@ -589,7 +589,7 @@ code does the parsing and validation of the syntax.
                          (format "expected a sequence of variables and an expression to follow ~a"
                                  (syntax-e #'kwd))
                          stx #'a))]
-                     [(#:post/name (id ...) str post-cond . leftover)
+                     [(#:post/name (id ...) str post-cond . pre-leftover)
                       (begin
                         (for-each (λ (x) (check-id stx x)) (syntax->list #'(id ...)))
                         (syntax-case range (any)
@@ -604,7 +604,7 @@ code does the parsing and validation of the syntax.
                             " declaration to be a string")
                            stx
                            #'str))
-                        (loop #'leftover
+                        (loop #'pre-leftover
                               (cons (pre/post (syntax->list #'(id ...)) (syntax-e #'str) #'post-cond
                                               (compute-quoted-src-expression #'post-cond))
                                     post-conds)))]
diff --git a/racket/collects/racket/contract/private/arr-i.rkt b/racket/collects/racket/contract/private/arr-i.rkt
index 240900e35e..a85e39cc0e 100644
--- a/racket/collects/racket/contract/private/arr-i.rkt
+++ b/racket/collects/racket/contract/private/arr-i.rkt
@@ -674,7 +674,8 @@ evaluted left-to-right.)
 ;;   (listof identifier) -- indy-arg/res-vars, bound to wrapped values with indy blame, 
 ;;        sorted like the second input
 ;;   (listof identifier) (listof arg/var) (listof identifier) (listof arg/var)
-;;        the last four inputs are used only to call arg/res-to-indy-var. 
+;;        the last four inputs are used only to call arg/res-to-indy-var.
+;;   boolean?
 ;; adds nested lets that bind the wrapper-args and the indy-arg/res-vars to projected values, 
 ;; with 'body' in the body of the let also handles adding code to check to see if unsupplied
 ;; args are present (skipping the contract check, if so) 
@@ -1119,6 +1120,7 @@ evaluted left-to-right.)
                        (coerce-chaperone-contract '->i orig-ctc)
                        (coerce-contract '->i orig-ctc)))
        (((get/build-late-neg-projection ctc) blame) obj neg-party)]))
+  
   (define (un-dep/chaperone orig-ctc obj blame neg-party indy-blame?)
     (un-dep/maybe-chaperone orig-ctc obj blame neg-party #t indy-blame?))
   
diff --git a/racket/collects/racket/contract/private/arrow-collapsible.rkt b/racket/collects/racket/contract/private/arrow-collapsible.rkt
new file mode 100644
index 0000000000..5cabdda508
--- /dev/null
+++ b/racket/collects/racket/contract/private/arrow-collapsible.rkt
@@ -0,0 +1,371 @@
+#lang racket/base
+
+;; collapsible arrow contracts
+;; supports a subset of full arrow contracts
+;; based on a prototype by Christophe Scholliers
+
+(require racket/unsafe/ops
+         "collapsible-common.rkt" "merge-cache.rkt"
+         (submod "collapsible-common.rkt" properties)
+         "prop.rkt" "guts.rkt" "misc.rkt" "blame.rkt" "arrow-common.rkt"
+         "arity-checking.rkt"
+         (for-syntax racket/base))
+
+(provide arrow-enter-collapsible-mode/continue
+         arrow-enter-collapsible-mode/collapse
+         val-has-arrow-collapsible-support?
+         ->-contract-has-collapsible-support?
+         build-collapsible-arrow)
+(module+ for-testing
+  (provide collapsible->? collapsible->-doms collapsible->-rng))
+
+;; General Strategy
+
+;; Each function contracted with a collapsible contract has two or three
+;; chaperone wrappers.
+;; - Functions that are wrapped in a "top-level" arrow contract (i.e., not a
+;;   subcontract of an arrow contract) are first contracted using a regular
+;;   function contract wrapper (before reaching this code). Upon being
+;;   contracted a second time, they reach this code, and get three chaperone
+;;   wrappers:
+;;   - first, an unsafe-chaperone wrapper, which chaperones the current
+;;     contracted value (to pretend it's it), but actually just calls the
+;;     original, uncontracted function (i.e. skips the original contract)
+;;   - second, a chaperone* wrapper, which gets passed the outermost wrapper,
+;;     and looks at a property on it to figure out what to check, then does
+;;     the actual contract checking
+;;   - third, a property-only chaperone wrapper, which has a collapsible contract
+;;     on a property, to keep track of which contracts to check.
+;;   When additional contracts are applied, this third chaperone is swapped out
+;;   for a new one, which keeps track of the new, merged contract to check.
+;;   Because it's a property-only chaperone, replacing it with a new one doesn't
+;;   affect chaperone-of-ness.
+;; - Functions that are wrapped in an "internal node" arrow contract (i.e.,
+;;   their arrow contract is a subcontract of another arrow contract) may be
+;;   wrapped with collapsible wrappers from the start (i.e., before getting
+;;   any other contract).
+;;   Note: This could be changed. Just avoid recursively converting contracts in
+;;     `ho/c->collapsible->`, and instead have doms and rngs be `ho-leaf/c` always.
+;;   Because of this, they don't need the first, unsafe chaperone wrapper above.
+;;   They only have the last two wrappers, otherwise the above strategy applies.
+
+;; Alternatively, we may try to attach an (internal node) collapsible
+;; contract to a value that doesn't support collapsible contracts (e.g.,
+;; a function that takes keyword arguments). In this case, we must fall back to
+;; regular contract wrapping, and convert the collapsible contract to a
+;; regular checking wrapper, as used elsewhere in the contract system (c.f.
+;; `bail-to-regular-wrapper`).
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data structures
+
+;; we store the most recent blame only. when contracts fail, they assign
+;; blame based on closed-over blame info, so `latest-blame` is only used
+;; for things like prop:blame, contract profiling, and tail marks, in which
+;; case we lose information, but it's ok to be conservative in these places
+;; (and this behavior is consistent with what would happen in the absence
+;; of collapsible contracts anyway)
+;; ditto for `latest-ctc` and prop:contracted
+(struct collapsible-> collapsible-ho/c (doms rng first-order-checks))
+
+;; contains all the information necessary to both (1) perform first order checks
+;; for an arrow contract, and (2) determine which such checks are redundant and
+;; can be eliminated
+(struct arrow-first-order-check (n-doms blame missing-party method?))
+;; stronger really means "the same" here
+(define (arrow-first-order-check-stronger? x y)
+  (= (arrow-first-order-check-n-doms x) (arrow-first-order-check-n-doms y)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Applicability checks
+
+(define (->-contract-has-collapsible-support? ctc)
+  (define-syntax-rule (bail reason)
+    (begin
+      (log-collapsible-contract-bailout-info (format "arrow: ~a" reason))
+      #f))
+  (cond [(collapsible->? ctc) ; already one
+         #t]
+        [(base->? ctc) ; only applies to regular arrow contracts (for now)
+         (define doms (base->-doms ctc))
+         (define rngs (base->-rngs ctc))
+         (and
+          ;; TODO: we can probably handle more of these cases for an -> contract
+          (or doms
+              (bail "no doms"))
+          (or (= (length doms) (base->-min-arity ctc)) ; no optional args
+              (bail "has optional args"))
+          (or (null? (base->-kwd-infos ctc)) ; no keyword args
+              (bail "has keyword args"))
+          (or (not (base->-rest ctc)) ; no rest arg
+              (bail "has rest arg"))
+          (or (not (base->-pre? ctc)) ; no pre-condition
+              (bail "has pre-condition"))
+          (or (not (base->-post? ctc)) ; no post-condition
+              (bail "has post-condition"))
+          (or rngs
+              (bail "no rngs"))
+          (or (= (length rngs) 1)
+              (bail "multiple return values")))]
+        [else
+         (bail "not base arrow")
+         #f]))
+
+(define (val-has-arrow-collapsible-support? val)
+  (define-syntax-rule (bail reason)
+    (begin
+      (log-collapsible-value-bailout-info (format "arrow: ~a" reason))
+      #f))
+  (and
+   (or (not (procedure-impersonator*? val))
+       (bail "procedure-impersonator*?"))
+   ;; the interposition wrapper has to support a superset of the arity
+   ;; of the function it's wrapping, and ours can't support optional
+   ;; args, keywords, etc. so just bail out in these cases
+
+   ;; TODO: I think we can actually support optional arguments without any additional work
+   ;; here ... so maybe this check can be removed
+   (or (integer? (procedure-arity val))
+       (bail "has optional args"))
+   (or (let-values ([(man opt) (procedure-keywords val)]) ; no keyword arguments
+         (and (null? man) (null? opt)))
+       (bail "has keyword args"))
+   ;; TODO: we can maybe support non single return value functions
+   (or (equal? (procedure-result-arity val) 1)
+       (bail "can't prove single-return-value"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Wrapper management and contract checking
+
+(define (arrow-collapsible-guard c-c val neg-party)
+  (do-arrow-first-order-checks c-c val neg-party)
+  (define chap-not-imp? (chaperone-collapsible->? c-c))
+  (define prop (get-impersonator-prop:collapsible val #f))
+  (define safe-for-c-c?
+    (if prop
+        (and (collapsible-property? prop)
+             (eq? (collapsible-property-ref prop) val))
+        (val-has-arrow-collapsible-support? val)))
+  (cond
+    [(not safe-for-c-c?) (bail-to-regular-wrapper c-c val neg-party)]
+    [(collapsible-wrapper-property? prop)
+     (arrow-enter-collapsible-mode/continue
+      c-c
+      val
+      neg-party
+      (collapsible-property-c-c prop)
+      (collapsible-property-neg-party prop)
+      (collapsible-wrapper-property-checking-wrapper prop)
+      chap-not-imp?)]
+    [(collapsible-count-property? prop)
+     (arrow-enter-collapsible-mode/collapse
+      c-c
+      val
+      neg-party
+      prop
+      chap-not-imp?)]
+    ;; else enter directly
+    [else
+     (arrow-enter-collapsible-mode/direct c-c val neg-party chap-not-imp?)]))
+
+(define (add-collapsible-arrow-chaperone merged c-c neg-party checking-wrapper chap-not-imp?)
+  (define chap/imp (if chap-not-imp? chaperone-procedure impersonate-procedure))
+  (define c-c-prop
+    (collapsible-wrapper-property merged neg-party #f checking-wrapper))
+  (define wrapped
+    (chap/imp
+     checking-wrapper
+     #f
+     impersonator-prop:collapsible c-c-prop))
+  (set-collapsible-property-ref! c-c-prop wrapped)
+  wrapped)
+
+
+(define (make-checking-wrapper unwrapped chap-not-imp?)
+  (if chap-not-imp?
+      (chaperone-procedure* unwrapped arrow-wrapper)
+      (impersonate-procedure* unwrapped arrow-wrapper)))
+
+(define (make-unsafe-checking-wrapper val unwrapped chap-not-imp?)
+  (if chap-not-imp?
+      (chaperone-procedure*
+       (unsafe-chaperone-procedure val unwrapped)
+       arrow-wrapper)
+      (impersonate-procedure*
+       (unsafe-impersonate-procedure val unwrapped)
+       arrow-wrapper)))
+
+;; If requested, we can log the arities of the contracts that end up being
+;; collapsible. That can inform whether we should have arity-specific
+;; wrappers, and if so, for which arities.
+(define-logger collapsible-contract-arrow-wrapper-arity)
+
+;; Create the 2nd chaperone wrapper procedure (see comment at the top),
+;; as well as "deoptimization" wrappers (see below).
+;; Checking wrappers come in different varieties, along two axes:
+;; - chaperone vs impersonator (to know how to wrap for subcontracts)
+;; - where to find the checks (on an impersonator property, for actual
+;;   collapsible contracts, vs closed over, for cases where we need
+;;   a regular contract wrapper (i.e., a subcontract has to "bail out,
+;;   and can't use the collapsible machinery (but since subcontracts
+;;   always start-out as collapsible, they can't bail out via the
+;;   checks in arrow-higher-order, so we need to handle them here)))
+(define-syntax (make-interposition-procedure stx)
+  (syntax-case stx ()
+    [(_ maybe-closed-over-m/c maybe-closed-over-neg)
+     ;; Note: it would be more efficient to have arity-specific wrappers here,
+     ;;   as opposed to using a rest arg.
+     #`(λ (outermost-chaperone . args)
+         (define-values (m/c neg-party)
+           #,(if (syntax-e #'maybe-closed-over-m/c)
+                 #'(values maybe-closed-over-m/c maybe-closed-over-neg)
+                 #'(let ()
+                     (define prop (get-impersonator-prop:collapsible outermost-chaperone))
+                     (values (collapsible-property-c-c prop)
+                             (collapsible-property-neg-party prop)))))
+         (define neg (or (collapsible-ho/c-missing-party m/c) neg-party))
+         (define doms   (collapsible->-doms         m/c))
+         (define rng    (collapsible->-rng          m/c))
+         (define blame  (collapsible-ho/c-latest-blame m/c))
+         (define blame+neg-party  (cons blame neg))
+         (define n-args (length args))
+         (define n-doms (length doms))
+         (log-collapsible-contract-arrow-wrapper-arity-info
+          (number->string n-doms))
+         (unless (= n-args n-doms)
+           (raise-wrong-number-of-args-error blame #:missing-party neg outermost-chaperone
+                                             n-args n-doms n-doms #f))
+         ;; Note: to support (i.e., not bail on) functions that can't be proven
+         ;;   to return a single value, have a `case-lambda` wrapper here. (With
+         ;;   the possibility of using return-arity-specific wrappers if return
+         ;;   arity happens to be known.)
+         ;; Note: should add tail-marks-match support here.
+         (define rng-checker
+           (lambda (result)
+             (with-collapsible-contract-continuation-mark
+               (with-contract-continuation-mark
+                 blame+neg-party
+                 (collapsible-guard rng result neg)))))
+         (apply values
+                rng-checker
+                (for/list ([dom (in-list doms)]
+                           [arg (in-list args)])
+                  (with-collapsible-contract-continuation-mark
+                    (with-contract-continuation-mark
+                      blame+neg-party
+                      (collapsible-guard dom arg neg))))))]))
+
+(define arrow-wrapper (make-interposition-procedure #f #f))
+
+;; create a regular checking wrapper from a collapsible wrapper for a value
+;; that can't use collapsible wrapping
+(define (bail-to-regular-wrapper m/c val neg-party)
+  (define chap-not-imp? (chaperone-collapsible->? m/c))
+  (define neg (or (collapsible-ho/c-missing-party m/c) neg-party))
+  ((if chap-not-imp? chaperone-procedure* impersonate-procedure*)
+   val
+   (make-interposition-procedure m/c neg)
+   impersonator-prop:contracted (collapsible-ho/c-latest-ctc   m/c)
+   impersonator-prop:blame (cons
+                            (collapsible-ho/c-latest-blame m/c)
+                            neg)))
+
+(define (do-arrow-first-order-checks m/c val neg-party)
+  (define checks (collapsible->-first-order-checks m/c))
+  (for ([c (in-list checks)])
+    (define n-doms (arrow-first-order-check-n-doms c))
+    (define partial-blame (arrow-first-order-check-blame c))
+    (define neg (arrow-first-order-check-missing-party c))
+    (cond [(do-arity-checking
+            partial-blame
+            val
+            (for/list ([i (in-range n-doms)]) #f) ; has to have the right length
+            #f ; no rest arg
+            n-doms ; min-arity = max-arity
+            '() ; no keywords
+            (arrow-first-order-check-method? c))
+           => (lambda (fail) (fail (or neg neg-party)))])))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; collapsible contract data structure management
+
+(define (build-collapsible-arrow rng doms ctc blame chap? [maybe-focs #f] [maybe-neg-blame #f])
+  (define focs
+    (or maybe-focs (list (arrow-first-order-check (length doms) blame maybe-neg-blame (base->-method? ctc)))))
+  (if chap?
+      (chaperone-collapsible-> blame maybe-neg-blame ctc doms rng focs)
+      (impersonator-collapsible-> blame maybe-neg-blame ctc doms rng focs)))
+
+;; merge two collapsible->
+(define/merge-cache (arrow-try-merge new-collapsible new-neg old-collapsible old-neg)
+  (define constructor (get-constructor new-collapsible old-collapsible))
+  (and constructor
+       (constructor
+        (collapsible-ho/c-latest-blame new-collapsible)
+        (or (collapsible-ho/c-missing-party new-collapsible) new-neg)
+        (collapsible-ho/c-latest-ctc   new-collapsible)
+        ;; if old and new don't have the same arity, then one of them will *have*
+        ;; to fail its first order checks, so we're fine.
+        ;; (we don't support optional arguments)
+        (merge-list (collapsible->-doms old-collapsible) old-neg (collapsible->-doms new-collapsible) new-neg)
+        (merge (collapsible->-rng new-collapsible) new-neg (collapsible->-rng old-collapsible) old-neg)
+        (arrow-first-order-merge
+         (collapsible->-first-order-checks new-collapsible) new-neg
+         (collapsible->-first-order-checks old-collapsible) old-neg))))
+
+(define (merge-list news new-neg olds old-neg)
+  (for/list ([new (in-list news)]
+             [old (in-list olds)])
+    (merge new new-neg old old-neg)))
+
+(define (arrow-first-order-merge new new-neg old old-neg)
+  (first-order-check-join
+   (add-f-o-neg-party new new-neg)
+   (add-f-o-neg-party old old-neg)
+   arrow-first-order-check-stronger?))
+
+(define arrow-enter-collapsible-mode/continue
+  (make-enter-collapsible-mode/continue
+   arrow-try-merge
+   add-collapsible-arrow-chaperone
+   bail-to-regular-wrapper))
+
+(define arrow-enter-collapsible-mode/collapse
+    (make-enter-collapsible-mode/collapse
+     make-unsafe-checking-wrapper
+     add-collapsible-arrow-chaperone
+     arrow-try-merge
+     bail-to-regular-wrapper))
+
+(define arrow-enter-collapsible-mode/direct
+  (make-enter-collapsible-mode/direct
+   make-checking-wrapper
+   add-collapsible-arrow-chaperone))
+
+(define (add-f-o-neg-party focs neg-party)
+  (for/list ([foc (in-list focs)])
+    (define missing-party (arrow-first-order-check-missing-party foc))
+    (struct-copy
+     arrow-first-order-check
+     foc
+     [missing-party (or missing-party neg-party)])))
+
+(define (get-constructor new old)
+  (or (and (chaperone-collapsible->? new)
+           (chaperone-collapsible->? old)
+           chaperone-collapsible->)
+      (and (impersonator-collapsible->? new)
+           (impersonator-collapsible->? old)
+           impersonator-collapsible->)))
+
+(define (->-collapsible-contract-property chap?)
+  (build-collapsible-contract-property
+   #:try-merge arrow-try-merge
+   #:collapsible-guard arrow-collapsible-guard))
+
+(struct chaperone-collapsible-> collapsible-> ()
+  #:property prop:collapsible-contract (->-collapsible-contract-property #t))
+(struct impersonator-collapsible-> collapsible-> ()
+  #:property prop:collapsible-contract (->-collapsible-contract-property #f))
diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt
index 3e8b195d99..1a2d535cc5 100644
--- a/racket/collects/racket/contract/private/arrow-higher-order.rkt
+++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt
@@ -10,6 +10,9 @@
          "guts.rkt"
          "list.rkt"
          (prefix-in arrow: "arrow-common.rkt")
+         "arrow-collapsible.rkt"
+         "collapsible-common.rkt"
+         (submod "collapsible-common.rkt" properties)
          (only-in racket/unsafe/ops
                   unsafe-chaperone-procedure
                   unsafe-impersonate-procedure))
@@ -541,6 +544,9 @@
                  min-arity doms kwd-infos rest pre? rngs post?
                  plus-one-arity-function chaperone-constructor method?
                  late-neg?)
+  (define has-c-c-support?
+    (->-contract-has-collapsible-support? ctc))
+  (define chaperone? (not is-impersonator?))
   (define optionals-length (- (length doms) min-arity))
   (define mtd? #f) ;; not yet supported for the new contracts
   (define okay-to-do-only-arity-check?
@@ -555,13 +561,18 @@
     (define rng-blame (arrow:blame-add-range-context orig-blame))
     (define swapped-domain (blame-add-context orig-blame "the domain of" #:swap? #t))
 
-    (define partial-doms
-      (for/list ([dom (in-list doms)]
-                 [n (in-naturals 1)])
-        ((get/build-late-neg-projection dom)
-         (blame-add-context orig-blame 
-                            (nth-argument-of (if method? (sub1 n) n))
-                            #:swap? #t))))
+    ;; if the ctc supports c-c mode, there are only positional args
+    (define-values (partial-doms c-c-doms)
+      (for/lists (projs ses)
+                 ([dom (in-list doms)]
+                  [n (in-naturals 1)])
+        (define dom-blame
+          (blame-add-context orig-blame
+                             (nth-argument-of (if method? (sub1 n) n))
+                             #:swap? #t))
+        (define prepared (get/build-collapsible-late-neg-projection dom))
+        (prepared dom-blame)))
+
     (define rest-blame
       (if (ellipsis-rest-arg-ctc? rest)
           (blame-swap orig-blame)
@@ -570,11 +581,14 @@
     (define partial-rest (and rest
                               ((get/build-late-neg-projection rest)
                                rest-blame)))
-    (define partial-ranges
-      (if rngs
-          (for/list ([rng (in-list rngs)])
-            ((get/build-late-neg-projection rng) rng-blame))
-          '()))
+    (define-values (partial-ranges maybe-c-c-ranges)
+      (cond
+        [rngs
+         (for/lists (proj c-c)
+                    ([rng (in-list rngs)])
+           (define prepared (get/build-collapsible-late-neg-projection rng))
+           (prepared rng-blame))]
+        [else (values '() #f)]))
     (define partial-kwds 
       (for/list ([kwd-info (in-list kwd-infos)]
                  [kwd (in-list kwd-infos)])
@@ -591,7 +605,9 @@
                          [kwd-info (in-list kwd-infos)]
                          #:unless (kwd-info-mandatory? kwd-info))
                 partial-kwd)))
-    
+    (define c-c-mergable
+      (and has-c-c-support?
+           (build-collapsible-arrow (car maybe-c-c-ranges) c-c-doms ctc orig-blame chaperone?)))
     (define the-args (append partial-doms
                              (if partial-rest (list partial-rest) '())
                              man-then-opt-partial-kwds
@@ -603,6 +619,17 @@
               (if partial-rest (list partial-rest) '())))
     (define blame-party-info (arrow:get-blame-party-info orig-blame))
     (define (successfully-got-the-right-kind-of-function val neg-party)
+      (define old-c-c-prop (get-impersonator-prop:collapsible val #f))
+      (define safe-for-c-c?
+        (and has-c-c-support?
+             (if old-c-c-prop
+                 (and (collapsible-property? old-c-c-prop)
+                      (eq? (collapsible-property-ref old-c-c-prop) val))
+                 (val-has-arrow-collapsible-support? val))))
+      (define wrapper-count
+        (if (collapsible-count-property? old-c-c-prop)
+            (collapsible-count-property-count old-c-c-prop)
+            0))
       (define-values (chap/imp-func use-unsafe-chaperone-procedure?)
         (apply chaperone-constructor
                orig-blame val
@@ -613,21 +640,60 @@
             (if is-impersonator? unsafe-impersonate-procedure unsafe-chaperone-procedure)
             (if is-impersonator? impersonate-procedure chaperone-procedure)))
       (cond
-        [chap/imp-func
+        [(not chap/imp-func)
+         val]
+        [(not safe-for-c-c?)
          (if (or post? (not rngs))
              (chaperone-or-impersonate-procedure
               val
               chap/imp-func
               impersonator-prop:contracted ctc
-              impersonator-prop:blame (blame-add-missing-party orig-blame neg-party))
+              impersonator-prop:blame (cons orig-blame neg-party))
              (chaperone-or-impersonate-procedure
               val
               chap/imp-func
               impersonator-prop:contracted ctc
-              impersonator-prop:blame (blame-add-missing-party orig-blame neg-party)
+              impersonator-prop:blame (cons orig-blame neg-party)
               impersonator-prop:application-mark
               (cons arrow:tail-contract-key (list* neg-party blame-party-info rngs))))]
-        [else val]))
+        [(wrapper-count . >= . COLLAPSIBLE-LIMIT)
+         (arrow-enter-collapsible-mode/collapse
+          c-c-mergable
+          val
+          neg-party
+          old-c-c-prop
+          chaperone?)]
+        [(collapsible-wrapper-property? old-c-c-prop)
+         (arrow-enter-collapsible-mode/continue
+          c-c-mergable
+          val
+          neg-party
+          (collapsible-property-c-c old-c-c-prop)
+          (collapsible-property-neg-party old-c-c-prop)
+          (collapsible-wrapper-property-checking-wrapper old-c-c-prop)
+          chaperone?)]
+        [else
+         (define c-c-prop
+           (collapsible-count-property
+            c-c-mergable
+            neg-party
+            #f
+            (add1 wrapper-count)
+            (or old-c-c-prop val)))
+         (define wrapped
+           (if (or post? (not rngs))
+             (chaperone-or-impersonate-procedure
+              val
+              chap/imp-func
+              impersonator-prop:collapsible c-c-prop)
+             (chaperone-or-impersonate-procedure
+              val
+              chap/imp-func
+              impersonator-prop:collapsible c-c-prop
+              impersonator-prop:application-mark
+              (cons arrow:tail-contract-key (list* neg-party blame-party-info rngs)))))
+         (set-collapsible-property-ref! c-c-prop wrapped)
+         wrapped]))
     (cond
       [late-neg?
        (define (arrow-higher-order:lnp val neg-party)
@@ -638,12 +704,18 @@
               (f neg-party))]
            [else
             (successfully-got-the-right-kind-of-function val neg-party)]))
-       (if okay-to-do-only-arity-check?
-           (λ (val neg-party)
-             (cond
-               [(arrow:procedure-arity-exactly/no-kwds val min-arity) val]
-               [else (arrow-higher-order:lnp val neg-party)]))
-           arrow-higher-order:lnp)]
+       (cond
+         [okay-to-do-only-arity-check?
+          (define lnp
+            (λ (val neg-party)
+              (cond
+                [(arrow:procedure-arity-exactly/no-kwds val min-arity) val]
+                [else (arrow-higher-order:lnp val neg-party)])))
+          (values lnp (or c-c-mergable (build-collapsible-leaf lnp ctc orig-blame)))]
+         [else
+          (values
+           arrow-higher-order:lnp
+           (or c-c-mergable (build-collapsible-leaf arrow-higher-order:lnp ctc orig-blame)))])]
       [else
        (define (arrow-higher-order:vfp val)
          (define-values (normal-proc proc-with-no-result-checking expected-number-of-results)
diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt
index 3487826c9a..2d08ff66e1 100644
--- a/racket/collects/racket/contract/private/arrow-val-first.rkt
+++ b/racket/collects/racket/contract/private/arrow-val-first.rkt
@@ -10,6 +10,8 @@
          "generate.rkt"
          "arrow-common.rkt"
          "arrow-higher-order.rkt"
+         "arrow-collapsible.rkt"
+         "collapsible-common.rkt"
          "list.rkt"
          racket/stxparam)
 
@@ -1543,7 +1545,7 @@
                (base->-chaperone-constructor ->stct)
                (base->-method? ->stct)
                #f)))
-  (define late-neg-proj
+  (define collapsible-late-neg-proj
     (λ (->stct)
       (->-proj is-impersonator? ->stct
                (base->-min-arity ->stct)
@@ -1572,7 +1574,7 @@
    #:generate ->-generate
    #:exercise ->-exercise
    #:val-first-projection val-first-proj
-   #:late-neg-projection late-neg-proj))
+   #:collapsible-late-neg-projection collapsible-late-neg-proj))
 
 (define (->-stronger this that)
   (and (base->? that)
diff --git a/racket/collects/racket/contract/private/collapsible-common.rkt b/racket/collects/racket/contract/private/collapsible-common.rkt
new file mode 100644
index 0000000000..302307d201
--- /dev/null
+++ b/racket/collects/racket/contract/private/collapsible-common.rkt
@@ -0,0 +1,335 @@
+#lang racket/base
+
+;; Common functionality used by all collapsible contracts
+
+(require "prop.rkt" "merge-cache.rkt")
+
+(provide (struct-out collapsible-ho/c)
+         (struct-out collapsible-leaf/c)
+         (struct-out collapsible-property)
+         (struct-out collapsible-count-property)
+         (struct-out collapsible-wrapper-property)
+         build-collapsible-leaf
+         prop:collapsible-contract
+         collapsible-contract-property?
+         build-collapsible-contract-property
+         collapsible-contract-property?
+         collapsible-contract?
+         merge
+         collapsible-guard
+         first-order-check-join
+         log-collapsible-value-bailout-info
+         log-collapsible-contract-bailout-info
+         log-collapsible-cache-fail-info
+         make-enter-collapsible-mode/continue
+         make-enter-collapsible-mode/collapse
+         make-enter-collapsible-mode/direct
+         COLLAPSIBLE-LIMIT)
+
+(module+ for-testing
+  (provide collapsible-leaf/c?
+           collapsible-leaf/c-contract-list
+           collapsible-leaf/c-proj-list
+           collapsible-property-c-c
+           collapsible-property-ref
+           has-impersonator-prop:collapsible?
+           get-impersonator-prop:collapsible
+           collapsible-wrapper-property?
+           collapsible-wrapper-property-checking-wrapper
+           calculate-drops))
+
+;; object contracts need to propagate properties across procedure->method
+(module+ properties
+  (provide impersonator-prop:collapsible
+           has-impersonator-prop:collapsible?
+           get-impersonator-prop:collapsible))
+
+(define-logger collapsible-value-bailout)
+(define-logger collapsible-contract-bailout)
+(define-logger collapsible-merging)
+(define-logger collapsible-cache-fail)
+
+(define COLLAPSIBLE-LIMIT 10)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Properties
+(define-values (impersonator-prop:collapsible
+                has-impersonator-prop:collapsible?
+                get-impersonator-prop:collapsible)
+  (make-impersonator-property 'impersonator-prop:collapsible))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; An interface for collapsible contract conversion and merging
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(struct collapsible-contract-property
+  (try-merge
+   collapsible-guard)
+  #:omit-define-syntaxes)
+
+(define (collapsible-contract-property-guard prop info)
+  (unless (collapsible-contract-property? prop)
+    (raise
+     (make-exn:fail:contract
+      (format "~a: expected a collapsible contract property; got: ~e"
+              prop)
+      (current-continuation-marks))))
+  prop)
+
+(define-values (prop:collapsible-contract collapsible-contract? get-collapsible-contract-property)
+  (make-struct-type-property 'collapsible-contract collapsible-contract-property-guard))
+
+(define (build-collapsible-contract-property
+         #:try-merge [try-merge #f]
+         #:collapsible-guard
+         [collapsible-guard
+          (lambda (ctc val neg)
+            (error "internal error: contract does not support `collapsible-guard`" ctc))])
+  (collapsible-contract-property
+   (or try-merge (lambda (_1 _2 _3 _4) #f))
+   collapsible-guard))
+
+;; Parent structure for higher order collapsible contracts
+;; which must keep track of the latest blame and missing party
+;; and latest contract applied
+(struct collapsible-ho/c (latest-blame missing-party latest-ctc))
+
+(struct collapsible-leaf/c (proj-list contract-list blame-list missing-party-list)
+  #:property prop:collapsible-contract
+  (build-collapsible-contract-property
+   #:try-merge (lambda (new new-neg old old-neg)
+                 (and (collapsible-leaf/c? old)
+                      (collapsible-leaf/c? new)
+                      (join-collapsible-leaf/c new new-neg old old-neg)))
+   #:collapsible-guard
+   (lambda (c-c val neg-party)
+     (apply-proj-list (collapsible-leaf/c-proj-list c-c)
+                      (collapsible-leaf/c-missing-party-list c-c)
+                      val
+                      neg-party))))
+
+(define (build-collapsible-leaf proj ctc blame)
+  (collapsible-leaf/c (list proj) (list ctc) (list blame) (list #f)))
+
+;; Allow the bailout to be passed as an optional to avoid
+;; an extra indirection through the property when possible
+(define (collapsible->leaf c neg-party [bail #f])
+  (cond
+    [(collapsible-leaf/c? c) c]
+    [else
+     (define bailout (or bail (get-bail c)))
+     (collapsible-leaf/c
+      (list bailout)
+      (list #f) ;; Bail out of ctc comparison when we see #f
+      (list (collapsible-ho/c-latest-blame c))
+      (list neg-party))]))
+
+;; Apply a list of projections over a value
+(define (apply-proj-list proj-list missing-parties val neg-party)
+  (for/fold ([val* val])
+            ([proj (in-list proj-list)]
+             [missing-party (in-list missing-parties)])
+    (proj val* (or missing-party neg-party))))
+
+;; checks whether the contract c is already implied by one of the
+;; contracts in contract-list
+(define (implied-by-one? contract-list c #:implies implies)
+  (for/or ([e (in-list contract-list)])
+    (implies e c)))
+
+(define (leaf-implied-by-one? contract-list new-ctc)
+  (and new-ctc
+       (for/or ([old-ctc (in-list contract-list)])
+         (and old-ctc
+              (flat-contract-struct? new-ctc)
+              (contract-struct-stronger? old-ctc new-ctc)))))
+
+;; join two collapsible-leaf contracts
+(define (join-collapsible-leaf/c new-collapsible new-neg old-collapsible old-neg)
+  (define new-proj-list (collapsible-leaf/c-proj-list new-collapsible))
+  (define new-flat-list (collapsible-leaf/c-contract-list new-collapsible))
+  (define new-blame-list (collapsible-leaf/c-blame-list new-collapsible))
+  (define new-missing-party-list (collapsible-leaf/c-missing-party-list new-collapsible))
+  (define old-proj-list (collapsible-leaf/c-proj-list old-collapsible))
+  (define old-flat-list (collapsible-leaf/c-contract-list old-collapsible))
+  (define old-blame-list (collapsible-leaf/c-blame-list old-collapsible))
+  ;; We have to traverse the list to add the new neg party where it is missing
+  (define old-missing-party-list (add-missing-parties (collapsible-leaf/c-missing-party-list old-collapsible) old-neg))
+  (define-values (not-implied-projs not-implied-flats not-implied-blames not-implied-missing-parties)
+    (for/lists (_1 _2 _3 _4) ([new-proj (in-list new-proj-list)]
+                              [new-flat (in-list new-flat-list)]
+                              [new-blame (in-list new-blame-list)]
+                              [new-missing-party (in-list new-missing-party-list)]
+                              #:when (not (leaf-implied-by-one? old-flat-list new-flat)))
+      (values new-proj new-flat new-blame (or new-missing-party new-neg))))
+  (define res-flats  (fast-append old-flat-list not-implied-flats))
+  (define res-blames (fast-append old-blame-list not-implied-blames))
+  (define res-missings (fast-append old-missing-party-list not-implied-missing-parties))
+  (define res-projs (fast-append old-proj-list not-implied-projs))
+  (define-values (pruned-projs pruned-flats pruned-blames pruned-missings)
+    (prune res-projs res-flats res-blames res-missings))
+  (collapsible-leaf/c pruned-projs pruned-flats pruned-blames pruned-missings))
+
+(define (add-missing-parties missing-parties new-neg-party)
+  (for/list ([neg-party (in-list missing-parties)])
+    (or neg-party new-neg-party)))
+
+(define (calculate-drops flats)
+  (define-values (to-drop _1 _2)
+       (for/fold ([indices '()]
+                  [seen (hasheq)]
+                  [maybe-drop (hasheq)])
+                 ([flat (in-list flats)]
+                  [i (in-naturals)])
+         (cond
+           [(or (flat-contract-struct? flat) (chaperone-contract-struct? flat))
+            (cond
+              [(hash-ref seen flat #f)
+               (define maybe-index (hash-ref maybe-drop flat #f))
+               (cond
+                 [maybe-index
+                  (define new-maybe-drop (hash-set maybe-drop flat i))
+                  (values (cons maybe-index indices) seen new-maybe-drop)]
+                 [else
+                  (define new-maybe-drop (hash-set maybe-drop flat i))
+                  (values indices seen new-maybe-drop)])]
+              [else
+               (define new-seen (hash-set seen flat #t))
+               (values indices new-seen maybe-drop)])]
+           [else
+            (values indices seen maybe-drop)])))
+  to-drop)
+
+(define (prune projs flats blames missings)
+  (cond
+    [((length flats) . <= . 10)
+     (define to-drop (calculate-drops flats))
+     (for/lists (_1 _2 _3 _4) ([proj (in-list projs)]
+                               [flat (in-list flats)]
+                               [blame (in-list blames)]
+                               [missing (in-list missings)]
+                               [i (in-naturals)]
+                               #:when (not (memv i to-drop)))
+       (values proj flat blame missing))]
+    [else (values projs flats blames missings)]))
+
+;; A specialized version of append that will immediately return if either
+;; argument is empty
+(define (fast-append l1 l2)
+  (cond
+    [(null? l2) l1]
+    [(null? l1) l2]
+    [else
+     (cons (car l1) (fast-append (cdr l1) l2))]))
+
+;; Assuming that merging is symmetric, ie old-can-merge? iff new-can-merge?
+;; This is true of the current c-c implementation, but if it ever changes
+;; this function will neef to check both directions for merging
+(define/merge-cache (merge new-c-c new-neg old-c-c old-neg)
+  (define-values (new-try-merge new-proj) (get-merge-components new-c-c))
+  (define-values (_ old-proj) (get-merge-components old-c-c))
+  (or (new-try-merge new-c-c new-neg old-c-c old-neg)
+      (join-collapsible-leaf/c (collapsible->leaf new-c-c new-neg new-proj)
+                         new-neg
+                         (collapsible->leaf old-c-c old-neg old-proj)
+                         old-neg)))
+
+(define (get-merge-components collapsible)
+  (define prop (get-collapsible-contract-property collapsible))
+  (define guard (collapsible-contract-property-collapsible-guard prop))
+  (values
+   (collapsible-contract-property-try-merge prop)
+   ;; FIXME: don't really want to build a lambda here ...
+   (λ (val neg) (guard collapsible val neg))))
+
+(define (collapsible-guard collapsible val neg-party)
+  (define prop (get-collapsible-contract-property collapsible))
+  (define guard (collapsible-contract-property-collapsible-guard prop))
+  (guard collapsible val neg-party))
+
+(define (get-bail collapsible)
+  (define prop (collapsible-contract-property collapsible))
+  (define guard (collapsible-contract-property-collapsible-guard prop))
+  ;; FIXME: don't really want to build this lambda ...
+  (λ (val neg) (guard collapsible val neg)))
+
+(define (first-order-check-join new-checks old-checks stronger?)
+  (fast-append old-checks
+
+               (for/list ([new (in-list new-checks)]
+                          #:when (not (implied-by-one?
+                                       old-checks new
+                                       #:implies stronger?)))
+                 new)))
+
+(struct collapsible-property (c-c neg-party [ref #:mutable]))
+(struct collapsible-count-property collapsible-property (count prev))
+(struct collapsible-wrapper-property collapsible-property (checking-wrapper))
+
+;; A Collapsible-Property is one of
+;; - (collapsible-count-property collapsible?
+;;                               neg-party?
+;;                               impersonator?
+;;                               natural-number/c
+;;                               (or/c collapsible-count-property?
+;;                                     (not/c collapsible-count-property?)))
+;;     a count of the contracts currently attached to the value along with other
+;;     necessary collapsible information
+;; - (collapsible-wrapper-property collapsible? neg-party? impersonator? impersonator?)
+;;     indicates this value is in collapsible mode, holds the attached collapsible contract,
+;;     the most recent neg-party, a pointer to the
+;;     last known collapsible wrapper, and the checking wrapper that has
+;;     the collapsible interposition functions
+
+(define (make-enter-collapsible-mode/direct
+         make-checking-wrapper
+         add-c-c-chaperone)
+  (λ (c-c val neg-party chap-not-imp?)
+    (define checking-wrapper (make-checking-wrapper val chap-not-imp?))
+    (add-c-c-chaperone c-c c-c neg-party checking-wrapper chap-not-imp?)))
+
+(define (make-enter-collapsible-mode/continue
+         try-merge
+         add-c-c-chaperone
+         bail)
+  (λ (new-c-c val new-neg-party c-c neg-party checking-wrapper chap-not-imp?)
+    (define merged-c-c (try-merge new-c-c new-neg-party c-c neg-party))
+    (cond
+      [merged-c-c
+       ;; Passing #f as the new-neg seems ugly, need to do more to fix this plumbing
+       (add-c-c-chaperone merged-c-c new-c-c #f checking-wrapper chap-not-imp?)]
+      [else (bail new-c-c val new-neg-party)])))
+
+(define (make-enter-collapsible-mode/collapse
+         make-unsafe-checking-wrapper
+         add-c-c-chaperone
+         try-merge
+         bail)
+  (λ (c-c val neg-party c-c-prop chap-not-imp?)
+    (define-values (merged-c-c checking-wrapper)
+      (let loop ([left c-c]
+                 [left-neg neg-party]
+                 [prop c-c-prop])
+        (cond
+          [left
+           (define right (collapsible-property-c-c prop))
+           (define right-neg (collapsible-property-neg-party prop))
+           (define prev (collapsible-count-property-prev prop))
+           (define merged (try-merge left left-neg right right-neg))
+           (cond
+             ;; there is another contract underneath this one
+             [(collapsible-count-property? prev)
+              (loop merged #f prev)]
+             ;; we've reached the bottom of the contract stack
+             [else
+              (define checking-wrapper
+                (make-unsafe-checking-wrapper val prev chap-not-imp?))
+              (values merged checking-wrapper)])]
+          ;; a merge failed, so we should return immediately
+          ;; indicating the failure
+          [else (values #f #f)])))
+    (cond
+      [merged-c-c
+       (add-c-c-chaperone merged-c-c c-c neg-party checking-wrapper chap-not-imp?)]
+      [else (bail c-c val neg-party)])))
diff --git a/racket/collects/racket/contract/private/guts.rkt b/racket/collects/racket/contract/private/guts.rkt
index 530aa31f06..e3df7dc166 100644
--- a/racket/collects/racket/contract/private/guts.rkt
+++ b/racket/collects/racket/contract/private/guts.rkt
@@ -5,6 +5,8 @@
          "prop.rkt"
          "rand.rkt"
          "generate-base.rkt"
+         "collapsible-common.rkt"
+         (submod "collapsible-common.rkt" properties)
          "../../private/math-predicates.rkt"
          racket/pretty
          racket/list
@@ -24,12 +26,14 @@
          contract-stronger?
          contract-equivalent?
          list-contract?
-         
+                  
          contract-first-order
          contract-first-order-passes?
          
          prop:contracted prop:blame
-         impersonator-prop:contracted impersonator-prop:blame
+         impersonator-prop:contracted
+         impersonator-prop:blame
+
          has-contract? value-contract
          has-blame? value-blame
          
@@ -57,6 +61,8 @@
          
          contract-continuation-mark-key
          with-contract-continuation-mark
+         collapsible-contract-continuation-mark-key
+         with-collapsible-contract-continuation-mark
          
          (struct-out wrapped-extra-arg-arrow)
          contract-custom-write-property-proc
@@ -67,6 +73,7 @@
          contract-late-neg-projection   ;; might return #f (if none)
          get/build-val-first-projection ;; builds one if necc., using contract-projection
          get/build-late-neg-projection
+         get/build-collapsible-late-neg-projection
          warn-about-val-first?
 
          contract-name
@@ -90,7 +97,8 @@
          false/c-contract
          true/c-contract
 
-         contract-pos/neg-doubling)
+         contract-pos/neg-doubling
+         contract-pos/neg-doubling.2)
 
 (define (contract-custom-write-property-proc stct port mode)
   (define (write-prefix)
@@ -153,7 +161,9 @@
 
 (define (has-contract? v)
   (or (has-prop:contracted? v)
-      (has-impersonator-prop:contracted? v)))
+      (has-impersonator-prop:contracted? v)
+      ;; TODO: I think this is the right check, but I'm not positive
+      (has-impersonator-prop:collapsible? v)))
 
 (define (value-contract v)
   (cond
@@ -161,11 +171,17 @@
      (get-prop:contracted v)]
     [(has-impersonator-prop:contracted? v)
      (get-impersonator-prop:contracted v)]
+    [(get-impersonator-prop:collapsible v #f)
+     =>
+     (λ (p)
+       (collapsible-ho/c-latest-ctc (collapsible-property-c-c p)))]
     [else #f]))
 
 (define (has-blame? v)
   (or (has-prop:blame? v)
-      (has-impersonator-prop:blame? v)))
+      (has-impersonator-prop:blame? v)
+      ;; TODO: I think this check is ok, but I'm not sure ...
+      (has-impersonator-prop:collapsible? v)))
 
 (define (value-blame v)
   (define bv
@@ -174,6 +190,13 @@
        (get-prop:blame v)]
       [(has-impersonator-prop:blame? v)
        (get-impersonator-prop:blame v)]
+      [(get-impersonator-prop:collapsible v #f)
+       =>
+       (λ (p)
+         (define c-c (collapsible-property-c-c p))
+         (cons
+          (collapsible-ho/c-latest-blame c-c)
+          (or (collapsible-ho/c-missing-party c-c) (collapsible-property-neg-party p))))]
       [else #f]))
   (cond
     [(and (pair? bv) (blame? (car bv)))
@@ -397,7 +420,8 @@
                                      name)
                                  x
                                  #f
-                                 (memq x the-known-good-contracts))])]
+                                 (or (struct-predicate-procedure? x)
+                                     (memq x the-known-good-contracts)))])]
     [(null? x)
      (unless list/c-empty
        (error 'coerce-contract/f::list/c-empty "too soon!"))
@@ -792,12 +816,27 @@
 
 (define-logger racket/contract)
 
+(define (get/build-collapsible-late-neg-projection ctc)
+  (cond
+    [(contract-struct-collapsible-late-neg-projection ctc) => values]
+    [else
+     (define lnp (get/build-late-neg-projection ctc))
+     (λ (blame)
+       (define proj (lnp blame))
+       (values proj
+               (build-collapsible-leaf proj ctc blame)))]))
+
 (define (get/build-late-neg-projection ctc)
   (cond
     [(contract-struct-late-neg-projection ctc) => values]
     [else
      (log-racket/contract-info "no late-neg-projection for ~s" ctc)
      (cond
+       [(contract-struct-collapsible-late-neg-projection ctc) =>
+        (lambda (f)
+          (lambda (blame)
+            (define-values (proj _) (f blame))
+            proj))]
        [(contract-struct-projection ctc)
         =>
         (λ (projection)
@@ -809,7 +848,7 @@
        [else
         (first-order->late-neg-projection (contract-struct-first-order ctc)
                                           (contract-struct-name ctc))])]))
-
+     
 (define (projection->late-neg-projection proj)
   (λ (b)
     (λ (x neg-party)
@@ -914,6 +953,13 @@
     (with-continuation-mark contract-continuation-mark-key payload
                             (let () code ...))))
 
+(define collapsible-contract-continuation-mark-key
+  (make-continuation-mark-key 'collapsible-contract))
+
+(define-syntax-rule (with-collapsible-contract-continuation-mark code ...)
+  (with-continuation-mark collapsible-contract-continuation-mark-key #t
+    (let () code ...)))
+  
 (define (n->th n)
   (string-append 
    (number->string n)
@@ -954,6 +1000,9 @@
 (define-syntax-rule
   (contract-pos/neg-doubling e1 e2)
   (contract-pos/neg-doubling/proc (λ () e1) (λ () e2)))
+(define-syntax-rule
+  (contract-pos/neg-doubling.2 e1 e2)
+  (contract-pos/neg-doubling.2/proc (λ () e1) (λ () e2)))
 (define doubling-cm-key (gensym 'racket/contract-doubling-mark))
 (define (contract-pos/neg-doubling/proc t1 t2)
   (define depth
@@ -965,4 +1014,18 @@
      (values #f t1 t2)]
     [else
      (with-continuation-mark doubling-cm-key (+ depth 1)
-       (values #t (t1) (t2)))]))
\ No newline at end of file
+       (values #t (t1) (t2)))]))
+(define (contract-pos/neg-doubling.2/proc t1 t2)
+  (define depth
+    (or (continuation-mark-set-first (current-continuation-marks)
+                                     doubling-cm-key)
+        0))
+  (cond
+    [(> depth 5)
+     (values #f t1 #f t2 #f)]
+    [else
+     (with-continuation-mark doubling-cm-key (+ depth 1)
+       (let ()
+         (define-values (t11 t12) (t1))
+         (define-values (t21 t22) (t2))
+         (values #t t11 t12 t21 t22)))]))
diff --git a/racket/collects/racket/contract/private/hash.rkt b/racket/collects/racket/contract/private/hash.rkt
index c5770b2afa..3dbc5133d6 100644
--- a/racket/collects/racket/contract/private/hash.rkt
+++ b/racket/collects/racket/contract/private/hash.rkt
@@ -332,25 +332,25 @@
        val
        (λ (h k)
          (values (with-contract-continuation-mark
-                  blame+neg-party
-                  (neg-dom-proj k neg-party))
+                   blame+neg-party
+                   (neg-dom-proj k neg-party))
                  (λ (h k v)
                    (with-contract-continuation-mark
-                    blame+neg-party
-                    ((mk-pos-rng-proj k) v neg-party)))))
+                     blame+neg-party
+                     ((mk-pos-rng-proj k) v neg-party)))))
        (λ (h k v)
          (with-contract-continuation-mark
-          blame+neg-party
-          (values (neg-dom-proj k neg-party)
-                  ((mk-neg-rng-proj k) v neg-party))))
+           blame+neg-party
+           (values (neg-dom-proj k neg-party)
+                   ((mk-neg-rng-proj k) v neg-party))))
        (λ (h k)
          (with-contract-continuation-mark
-          blame+neg-party
-          (neg-dom-proj k neg-party)))
+           blame+neg-party
+           (neg-dom-proj k neg-party)))
        (λ (h k)
          (with-contract-continuation-mark
-          blame+neg-party
-          (pos-dom-proj k neg-party)))
+           blame+neg-party
+           (pos-dom-proj k neg-party)))
        impersonator-prop:contracted ctc
        impersonator-prop:blame blame)))
 
diff --git a/racket/collects/racket/contract/private/list.rkt b/racket/collects/racket/contract/private/list.rkt
index 7bafc0a7b3..717d16cbf8 100644
--- a/racket/collects/racket/contract/private/list.rkt
+++ b/racket/collects/racket/contract/private/list.rkt
@@ -1006,7 +1006,7 @@
                blame
                val
                '(expected: "list?" given: "~e") val)]))))
-  
+
 ;; prefix : contract
 ;; suffix : (listof contract)
 (struct *list-ctc (prefix suffix)
diff --git a/racket/collects/racket/contract/private/merge-cache.rkt b/racket/collects/racket/contract/private/merge-cache.rkt
new file mode 100644
index 0000000000..c23d172c21
--- /dev/null
+++ b/racket/collects/racket/contract/private/merge-cache.rkt
@@ -0,0 +1,60 @@
+#lang racket/base
+
+(provide define/merge-cache)
+
+(require (for-syntax racket/base))
+
+;; weak hashtable never cleared
+(define MERGE-CACHE (make-thread-cell (make-weak-hasheq)))
+
+(require (for-syntax racket/base))
+(define-syntax (define/merge-cache stx)
+  (syntax-case stx ()
+    [(_ (merge-name new-se new-neg old-se old-neg) body ...)
+     #'(define (merge-name new-se new-neg old-se old-neg)
+         (call-with-merge-cache new-se new-neg old-se old-neg
+           (let ([merge-name (λ () body ...)])
+             merge-name)))]))
+
+(define (call-with-merge-cache new-se new-neg old-se old-neg body-thunk)
+  (define the-cache (thread-cell-ref MERGE-CACHE))
+  (define h1 (hash-ref the-cache new-se #f))
+  (cond
+    [(and h1 (ephemeron-value h1))
+     =>
+     (λ (h1)
+       (define h2 (hash-ref h1 new-neg #f))
+       (cond
+         [(and h2 (ephemeron-value h2))
+          =>
+          (λ (h2)
+            (define h3 (hash-ref h2 old-se #f))
+            (cond
+              [(and h3 (ephemeron-value h3))
+               =>
+               (λ (h3)
+                 (define cached-result (hash-ref h3 old-neg #f))
+                 (cond
+                   [(ephemeron-value cached-result) => values]
+                   [else
+                    (define result (body-thunk))
+                    (hash-set! h3 old-neg (make-ephemeron old-neg result))
+                    result]))]
+              [else
+               (define result (body-thunk))
+               (define h3 (make-hasheq (list (cons old-neg (make-ephemeron old-neg result)))))
+               (hash-set! h2 old-se (make-ephemeron old-se h3))
+               result]))]
+         [else
+          (define result (body-thunk))
+          (define h3 (make-hasheq (list (cons old-neg (make-ephemeron old-neg result)))))
+          (define h2 (make-hasheq (list (cons old-se (make-ephemeron old-se h3)))))
+          (hash-set! h1 new-neg (make-ephemeron new-neg h2))
+          result]))]
+    [else
+     (define result (body-thunk))
+     (define h3 (make-hasheq (list (cons old-neg (make-ephemeron old-neg result)))))
+     (define h2 (make-hasheq (list (cons old-se (make-ephemeron old-se h3)))))
+     (define h1 (make-hasheq (list (cons new-neg (make-ephemeron new-neg h2)))))
+     (hash-set! the-cache new-se (make-ephemeron new-se h1))
+     result]))
diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt
index 4e95ace5a7..75e875bc34 100644
--- a/racket/collects/racket/contract/private/misc.rkt
+++ b/racket/collects/racket/contract/private/misc.rkt
@@ -477,6 +477,7 @@
    #:stronger promise-ctc-stronger?
    #:equivalent promise-ctc-equivalent?
    #:first-order (λ (ctc) promise?)))
+
 (struct promise-ctc promise-base-ctc ()
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
@@ -524,6 +525,7 @@
                 (with-contract-continuation-mark
                  blame+neg-party
                  (f x neg-party))))
+            ;; TODO this ought to have the `contracted` property, but it's not a chaperone...
             (make-derived-parameter
              val
              (add-profiling in-proj)
diff --git a/racket/collects/racket/contract/private/parametric.rkt b/racket/collects/racket/contract/private/parametric.rkt
index 3f291de611..d0bccdfc9c 100644
--- a/racket/collects/racket/contract/private/parametric.rkt
+++ b/racket/collects/racket/contract/private/parametric.rkt
@@ -88,7 +88,7 @@
               (barrier/c negative? var)))
           (define protector
             (apply (polymorphic-contract-body c) instances))
-          (((get/build-late-neg-projection protector) blame) p neg-party)))
+           (((get/build-late-neg-projection protector) blame) p neg-party)))
 
        (lambda (p neg-party)
          (unless (procedure? p)
diff --git a/racket/collects/racket/contract/private/prop.rkt b/racket/collects/racket/contract/private/prop.rkt
index 77a023eb64..b6105b27f5 100644
--- a/racket/collects/racket/contract/private/prop.rkt
+++ b/racket/collects/racket/contract/private/prop.rkt
@@ -11,6 +11,7 @@
          contract-struct-projection
          contract-struct-val-first-projection
          contract-struct-late-neg-projection
+         contract-struct-collapsible-late-neg-projection
          contract-struct-stronger?
          contract-struct-equivalent?
          contract-struct-generate
@@ -68,6 +69,7 @@
                                    exercise
                                    val-first-projection
                                    late-neg-projection
+                                   collapsible-late-neg-projection
                                    list-contract? ]
   #:omit-define-syntaxes)
 
@@ -113,6 +115,12 @@
   (and get-projection
        (get-projection c)))
 
+(define (contract-struct-collapsible-late-neg-projection c)
+  (define prop (contract-struct-property c))
+  (define get-collapsible-projection (contract-property-collapsible-late-neg-projection prop))
+  (and get-collapsible-projection
+       (get-collapsible-projection c)))
+
 (define (contract-struct-stronger/equivalent?
          a b
          trail
@@ -296,6 +304,7 @@
          #:projection [get-projection #f]
          #:val-first-projection [get-val-first-projection #f]
          #:late-neg-projection [get-late-neg-projection #f]
+         #:collapsible-late-neg-projection [get-collapsible-late-neg-projection #f]
          #:stronger [stronger #f]
          #:equivalent [equivalent #f]
          #:generate [generate (λ (ctc) (λ (fuel) #f))]
@@ -312,12 +321,14 @@
       " #:projection, #:val-first-projection, #:late-neg-projection, or #:first-order"
       " argument to not be #f, but all four were #f")))
 
+  ;; TODO: update for collapsible late-neg-projection
   (unless get-late-neg-projection
-    (unless first-order?
-      (log-racket/contract-info
-       "no late-neg-projection passed to ~s~a"
-       proc-name
-       (build-context))))
+    (unless get-collapsible-late-neg-projection
+      (unless first-order?
+        (log-racket/contract-info
+         "no late-neg-projection passed to ~s~a"
+         proc-name
+         (build-context)))))
 
   (unless (and (procedure? list-contract?)
                (procedure-arity-includes? list-contract? 1))
@@ -344,6 +355,7 @@
             (λ (c) (late-neg-first-order-projection (get-name c) (get-first-order c)))]
            [else #f])]
         [else get-late-neg-projection])
+      get-collapsible-late-neg-projection
       list-contract?))
 
 (define (build-context)
@@ -406,7 +418,8 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define-struct make-contract [ name first-order projection
-                                    val-first-projection late-neg-projection 
+                                    val-first-projection late-neg-projection
+                                    collapsible-late-neg-projection
                                     stronger equivalent generate exercise list-contract? ]
   #:omit-define-syntaxes
   #:property prop:custom-write
@@ -421,6 +434,7 @@
    #:projection (lambda (c) (make-contract-projection c))
    #:val-first-projection (lambda (c) (make-contract-val-first-projection c))
    #:late-neg-projection (lambda (c) (make-contract-late-neg-projection c))
+   #:collapsible-late-neg-projection (lambda (c) (make-contract-collapsible-late-neg-projection c))
    #:stronger (lambda (a b) ((make-contract-stronger a) a b))
    #:generate (lambda (c) (make-contract-generate c))
    #:exercise (lambda (c) (make-contract-exercise c))
@@ -428,6 +442,7 @@
 
 (define-struct make-chaperone-contract [ name first-order projection
                                               val-first-projection late-neg-projection
+                                              collapsible-late-neg-projection
                                               stronger equivalent generate exercise list-contract? ]
   #:omit-define-syntaxes
   #:property prop:custom-write
@@ -442,6 +457,7 @@
    #:projection (lambda (c) (make-chaperone-contract-projection c))
    #:val-first-projection (lambda (c) (make-chaperone-contract-val-first-projection c))
    #:late-neg-projection (lambda (c) (make-chaperone-contract-late-neg-projection c))
+   #:collapsible-late-neg-projection (lambda (c) (make-chaperone-contract-collapsible-late-neg-projection c))
    #:stronger (lambda (a b) ((make-chaperone-contract-stronger a) a b))
    #:generate (lambda (c) (make-chaperone-contract-generate c))
    #:exercise (lambda (c) (make-chaperone-contract-exercise c))
@@ -449,6 +465,7 @@
 
 (define-struct make-flat-contract [ name first-order projection
                                          val-first-projection late-neg-projection
+                                         collapsible-late-neg-projection
                                          stronger equivalent generate exercise list-contract? ]
   #:omit-define-syntaxes
   #:property prop:custom-write
@@ -462,6 +479,7 @@
    #:first-order (lambda (c) (make-flat-contract-first-order c))
    #:val-first-projection (λ (c) (make-flat-contract-val-first-projection c))
    #:late-neg-projection (λ (c) (make-flat-contract-late-neg-projection c))
+   #:collapsible-late-neg-projection (lambda (c) (make-flat-contract-collapsible-late-neg-projection c))
    #:projection (lambda (c) (make-flat-contract-projection c))
    #:stronger (lambda (a b) ((make-flat-contract-stronger a) a b))
    #:generate (lambda (c) (make-flat-contract-generate c))
@@ -474,6 +492,7 @@
          #:projection [projection #f]
          #:val-first-projection [val-first-projection #f]
          #:late-neg-projection [late-neg-projection #f]
+         #:collapsible-late-neg-projection [collapsible-late-neg-projection #f]
          #:stronger [stronger #f]
          #:equivalent [equivalent #f]
          #:generate [generate (λ (fuel) #f)]
@@ -491,12 +510,14 @@
       " #:projection, #:val-first-projection, #:late-neg-projection, or #:first-order"
       " argument to not be #f, but all four were #f")))
   
+  ;; TODO: handle the addition of the collapsible-late-neg-projection
   (unless late-neg-projection
-    (unless first-order?
-      (log-racket/contract-info
-       "no late-neg-projection passed to ~s~a"
-       proc-name
-       (build-context))))
+    (unless collapsible-late-neg-projection
+      (unless first-order?
+        (log-racket/contract-info
+         "no late-neg-projection passed to ~s~a"
+         proc-name
+         (build-context)))))
 
   (mk (or name default-name)
       (or first-order any?) 
@@ -509,6 +530,7 @@
             (late-neg-first-order-projection name first-order)]
            [else #f])]
         [else late-neg-projection])
+      collapsible-late-neg-projection
       (or stronger weakest)
       (or equivalent (if equivalent-equal? equal? weakest))
       generate exercise
diff --git a/racket/collects/racket/contract/private/vector-collapsible.rkt b/racket/collects/racket/contract/private/vector-collapsible.rkt
new file mode 100644
index 0000000000..11e0808305
--- /dev/null
+++ b/racket/collects/racket/contract/private/vector-collapsible.rkt
@@ -0,0 +1,261 @@
+#lang racket/base
+
+(require "prop.rkt" "guts.rkt" "blame.rkt" "vector-common.rkt"
+         "collapsible-common.rkt" "merge-cache.rkt"
+         (submod "collapsible-common.rkt" properties)
+         (only-in racket/unsafe/ops unsafe-chaperone-vector unsafe-impersonate-vector)
+         (for-syntax racket/base))
+
+(provide build-collapsible-vector
+         build-doubling-collapsible-vector
+         vector-collapsible-guard
+         vector-enter-collapsible-mode/continue
+         vector-enter-collapsible-mode/collapse)
+
+(module+ for-testing
+  (provide  collapsible-vector? collapsible-vector-ref-ctcs collapsible-vector-set-ctcs))
+
+(struct vector-first-order-check (immutable length blame missing-party))
+
+;; mutable field are only to support impersonation in `build-doubling-c-c-vector`
+(struct collapsible-vector collapsible-ho/c (first-order [ref-ctcs #:mutable] [set-ctcs #:mutable]) #:transparent)
+
+(define (do-vector-first-order-checks m/c val neg-party)
+  (define checks (collapsible-vector-first-order m/c))
+  (for ([c (in-list checks)])
+    (define immutable (vector-first-order-check-immutable c))
+    (define length (vector-first-order-check-length c))
+    (define blame (vector-first-order-check-blame c))
+    (define neg (or (vector-first-order-check-missing-party c) neg-party))
+    (check-vector/c val blame immutable length neg)))
+
+(define (vector-first-order-check-stronger? f1 f2)
+  (define f1-immutable (vector-first-order-check-immutable f1))
+  (define f1-length (vector-first-order-check-length f1))
+  (define f2-immutable (vector-first-order-check-immutable f2))
+  (define f2-length (vector-first-order-check-length f2))
+  (and (or (eq? f2-immutable 'dont-care)
+           (eq? f1-immutable f2-immutable))
+       (or (not f2-length)
+           (and f1-length (= f1-length f2-length)))))
+
+(define (build-collapsible-vector c-c-pos c-c-neg ctc blame chap-not-imp?)
+  (define focs (list (build-vector-first-order-checks ctc blame)))
+  (if chap-not-imp?
+      (chaperone-collapsible-vector blame #f ctc focs c-c-pos c-c-neg)
+      (impersonator-collapsible-vector blame #f ctc focs c-c-pos c-c-neg)))
+
+(define (build-doubling-collapsible-vector fetch-c-c-pos fetch-c-c-neg ctc blame chap-not-imp?)
+  (define focs (list (build-vector-first-order-checks ctc blame)))
+  (define dummy
+    (if chap-not-imp?
+        (chaperone-collapsible-vector blame #f ctc focs 'dummy-c-c-pos 'dummy-c-c-neg)
+        (impersonator-collapsible-vector blame #f ctc focs 'dummy-c-c-pos 'dummy-c-c-neg)))
+  (impersonate-struct dummy
+                      collapsible-vector-ref-ctcs
+                      (λ (self field-v) (fetch-c-c-pos))
+                      collapsible-vector-set-ctcs
+                      (λ (self field-v) (fetch-c-c-neg))))
+
+(define (build-vector-first-order-checks ctc blame)
+  (cond
+    [(base-vectorof? ctc)
+     (vector-first-order-check
+      (base-vectorof-immutable ctc)
+      #f
+      blame
+      #f)]
+    [(base-vector/c? ctc)
+     (vector-first-order-check
+      (base-vector/c-immutable ctc)
+      (length (base-vector/c-elems ctc))
+      blame
+      #f)]))
+
+(define (add-f-o-neg-party focs neg-party)
+  (for/list ([foc (in-list focs)])
+    (define missing-party (vector-first-order-check-missing-party foc))
+    (struct-copy
+     vector-first-order-check
+     foc
+     [missing-party (or missing-party neg-party)])))
+
+(define (vector-first-order-merge new new-neg old old-neg)
+  (first-order-check-join
+   (add-f-o-neg-party new new-neg)
+   (add-f-o-neg-party old old-neg)
+   vector-first-order-check-stronger?))
+
+(define/merge-cache (vector-try-merge new-collapsible new-neg old-collapsible old-neg)
+  (define constructor (get-constructor new-collapsible old-collapsible))
+  (and constructor
+       (constructor
+        (collapsible-ho/c-latest-blame new-collapsible)
+        (or (collapsible-ho/c-missing-party new-collapsible) new-neg)
+        (collapsible-ho/c-latest-ctc new-collapsible)
+        (vector-first-order-merge
+         (collapsible-vector-first-order new-collapsible) new-neg
+         (collapsible-vector-first-order old-collapsible) old-neg)
+        (merge* (collapsible-vector-ref-ctcs new-collapsible)
+                new-neg
+                (collapsible-vector-ref-ctcs old-collapsible)
+                old-neg)
+        (merge* (collapsible-vector-set-ctcs old-collapsible)
+                old-neg
+                (collapsible-vector-set-ctcs new-collapsible)
+                new-neg))))
+
+(define (merge* new new-neg old old-neg)
+  (cond
+    [(and (vector? new) (vector? old))
+     (for/vector ([nc (in-vector new)]
+                  [oc (in-vector old)])
+       (merge nc new-neg oc old-neg))]
+    [(vector? new)
+     (for/vector ([nc (in-vector new)])
+       (merge nc new-neg old old-neg))]
+    [(vector? old)
+     (for/vector ([oc (in-vector old)])
+       (merge new new-neg oc old-neg))]
+    [else
+     (merge new new-neg old old-neg)]))
+
+(define (get-constructor new old)
+  (or (and (chaperone-collapsible-vector? new)
+           (chaperone-collapsible-vector? old)
+           chaperone-collapsible-vector)
+      (and (impersonator-collapsible-vector? new)
+           (impersonator-collapsible-vector? old)
+           impersonator-collapsible-vector)))
+
+(define (vector-collapsible-guard c-c val neg-party)
+  (do-vector-first-order-checks c-c val neg-party)
+  (define chap-not-imp? (chaperone-collapsible-vector? c-c))
+  (define prop (get-impersonator-prop:collapsible val #f))
+  (define safe-for-c-c?
+    (if prop
+        (and (collapsible-property? prop)
+             (eq? (collapsible-property-ref prop) val))
+        (not (impersonator? val))))
+  (cond
+    ;; not safe, bail out
+    [(not safe-for-c-c?)
+     (bail-to-regular-wrapper c-c val neg-party)]
+    ;; already in c-c mode, so stay in
+    [(collapsible-wrapper-property? prop)
+     (vector-enter-collapsible-mode/continue
+      c-c
+      val
+      neg-party
+      (collapsible-property-c-c prop)
+      (collapsible-property-neg-party prop)
+      (collapsible-wrapper-property-checking-wrapper prop)
+      chap-not-imp?)]
+    ;; need to collapse contracts ...
+    [(collapsible-count-property? prop)
+     (vector-enter-collapsible-mode/collapse
+      c-c
+      val
+      neg-party
+      prop
+      chap-not-imp?)]
+    ;; else enter directly
+    [else
+     (vector-enter-collapsible-mode/direct c-c val neg-party chap-not-imp?)]))
+
+(define (add-collapsible-vector-chaperone merged c-c neg-party checking-wrapper chap-not-imp?)
+  (define chap/imp (if chap-not-imp? chaperone-vector impersonate-vector))
+  (define c-c-prop
+    (collapsible-wrapper-property merged neg-party #f checking-wrapper))
+  (define wrapped
+    (chap/imp
+     checking-wrapper
+     #f
+     #f
+     impersonator-prop:collapsible c-c-prop))
+  (set-collapsible-property-ref! c-c-prop wrapped)
+  wrapped)
+
+(define (make-checking-wrapper unwrapped chap-not-imp?)
+  (if chap-not-imp?
+      (chaperone-vector* unwrapped ref-wrapper set-wrapper)
+      (impersonate-vector* unwrapped ref-wrapper set-wrapper)))
+
+(define (make-unsafe-checking-wrapper val unwrapped chap-not-imp?)
+  (if chap-not-imp?
+      (chaperone-vector*
+       (unsafe-chaperone-vector val unwrapped)
+       ref-wrapper
+       set-wrapper)
+      (impersonate-vector*
+       (unsafe-impersonate-vector val unwrapped)
+       ref-wrapper
+       set-wrapper)))
+
+(define-syntax (make-vector-checking-wrapper stx)
+  (syntax-case stx ()
+    [(_ set? maybe-closed-over-m/c maybe-closed-over-neg)
+     #`(λ (outermost v i elt)
+         (define-values (m/c neg-party)
+           #,(if (syntax-e #'maybe-closed-over-m/c)
+                 #'(values maybe-closed-over-m/c maybe-closed-over-neg)
+                 #'(let ()
+                     (define prop (get-impersonator-prop:collapsible outermost))
+                     (values (collapsible-property-c-c prop)
+                             (collapsible-property-neg-party prop)))))
+         (define neg (or (collapsible-ho/c-missing-party m/c) neg-party))
+         (define field
+           #,(if (syntax-e #'set?)
+                 #'(collapsible-vector-set-ctcs m/c)
+                 #'(collapsible-vector-ref-ctcs m/c)))
+         (define c-c
+           (if (vector? field) (vector-ref field i) field))
+         (define blame (cons (collapsible-ho/c-latest-blame m/c) neg))
+         (with-collapsible-contract-continuation-mark
+             (with-contract-continuation-mark
+                 blame
+               (collapsible-guard c-c elt neg))))]))
+
+(define ref-wrapper (make-vector-checking-wrapper #f #f #f))
+(define set-wrapper (make-vector-checking-wrapper #t #f #f))
+
+(define (bail-to-regular-wrapper m/c val neg-party)
+  (define chap-not-imp? (chaperone-collapsible-vector? m/c))
+  (define neg (or (collapsible-ho/c-missing-party m/c) neg-party))
+  (define blame (cons (collapsible-ho/c-latest-blame m/c) neg))
+  (define ctc (collapsible-ho/c-latest-ctc m/c))
+  (define merged+neg-party (cons m/c neg))
+  ((if chap-not-imp? chaperone-vector* impersonate-vector*)
+   val
+   (make-vector-checking-wrapper #f m/c neg)
+   (make-vector-checking-wrapper #t m/c neg)
+   impersonator-prop:contracted ctc
+   impersonator-prop:blame blame))
+
+(define vector-enter-collapsible-mode/continue
+  (make-enter-collapsible-mode/continue
+   vector-try-merge
+   add-collapsible-vector-chaperone
+   bail-to-regular-wrapper))
+
+(define vector-enter-collapsible-mode/collapse
+  (make-enter-collapsible-mode/collapse
+   make-unsafe-checking-wrapper
+   add-collapsible-vector-chaperone
+   vector-try-merge
+   bail-to-regular-wrapper))
+
+(define vector-enter-collapsible-mode/direct
+  (make-enter-collapsible-mode/direct
+   make-checking-wrapper
+   add-collapsible-vector-chaperone))
+
+(define (vector-collapsible-contract-property chap-not-imp?)
+  (build-collapsible-contract-property
+   #:try-merge vector-try-merge
+   #:collapsible-guard vector-collapsible-guard))
+
+(struct chaperone-collapsible-vector collapsible-vector ()
+  #:property prop:collapsible-contract (vector-collapsible-contract-property #t))
+(struct impersonator-collapsible-vector collapsible-vector ()
+  #:property prop:collapsible-contract (vector-collapsible-contract-property #f))
diff --git a/racket/collects/racket/contract/private/vector-common.rkt b/racket/collects/racket/contract/private/vector-common.rkt
new file mode 100644
index 0000000000..8030772d3b
--- /dev/null
+++ b/racket/collects/racket/contract/private/vector-common.rkt
@@ -0,0 +1,67 @@
+#lang racket/base
+
+(require "blame.rkt")
+
+(provide (struct-out base-vectorof)
+         (struct-out base-vector/c)
+         do-check-vectorof
+         check-vector/c)
+
+;; eager is one of:
+;; - #t: always perform an eager check of the elements of an immutable vector
+;; - #f: never  perform an eager check of the elements of an immutable vector
+;; - N (for N>=0): perform an eager check of immutable vectors size <= N
+(define-struct base-vectorof (elem immutable eager))
+
+(define-struct base-vector/c (elems immutable))
+
+
+(define (do-check-vectorof val immutable blame neg-party raise-blame?)
+  (cond
+    [(vector? val)
+     (cond
+       [(eq? immutable #t)
+        (cond
+          [(immutable? val) #t]
+          [raise-blame?
+           (raise-blame-error
+            blame
+            #:missing-party neg-party
+            val
+            '(expected "an immutable vector" given: "~e")
+            val)]
+          [else #f])]
+       [(eq? immutable #f)
+        (cond
+          [(not (immutable? val)) #t]
+          [raise-blame?
+           (raise-blame-error
+            blame
+            #:missing-party neg-party
+            val
+            '(expected "an mutable vector" given: "~e")
+            val)]
+          [else #f])]
+       [else #t])]
+    [raise-blame?
+     (raise-blame-error
+      blame
+      #:missing-party neg-party
+      val
+      '(expected "an immutable vector" given: "~e")
+      val)]
+    [else #f]))
+
+(define (check-vector/c val blame immutable length neg-party)
+  (define (raise-blame val . args)
+    (apply raise-blame-error blame #:missing-party neg-party val args))
+  (do-check-vectorof val immutable blame neg-party #t)
+  (unless (or (not length) (= (vector-length val) length))
+    (raise-blame-error
+     blame
+     #:missing-party neg-party
+     val
+     '(expected: "a vector of ~a element~a" given: "~e")
+     length
+     (if (= length 1) "" "s")
+     val)))
diff --git a/racket/collects/racket/contract/private/vector.rkt b/racket/collects/racket/contract/private/vector.rkt
index 08f66c19ac..8f91f97eb0 100644
--- a/racket/collects/racket/contract/private/vector.rkt
+++ b/racket/collects/racket/contract/private/vector.rkt
@@ -4,18 +4,16 @@
          "guts.rkt"
          "prop.rkt"
          "blame.rkt"
-         "misc.rkt")
+         "misc.rkt"
+         "collapsible-common.rkt"
+         (submod "collapsible-common.rkt" properties)
+         "vector-common.rkt"
+         "vector-collapsible.rkt")
 
 (provide (rename-out [wrap-vectorof vectorof]
                      [wrap-vector/c vector/c])
          vector-immutable/c vector-immutableof)
 
-;; eager is one of:
-;; - #t: always perform an eager check of the elements of an immutable vector
-;; - #f: never  perform an eager check of the elements of an immutable vector
-;; - N (for N>=0): perform an eager check of immutable vectors size <= N
-(define-struct base-vectorof (elem immutable eager))
-
 (define-for-syntax (convert-args args this-one)
   (let loop ([args args]
              [new-args null])
@@ -50,32 +48,29 @@
                 (list '#:immutable immutable)
                 null)))))
 
-(define (check-vectorof c) 
-  (let ([elem-ctc (base-vectorof-elem c)]
-        [immutable (base-vectorof-immutable c)]
-        [flat? (flat-vectorof? c)])
-    (λ (val fail first-order?)
-      (unless (vector? val)
-        (fail val '(expected "a vector," given: "~e") val))
-      (cond
-        [(eq? immutable #t)
-         (unless (immutable? val)
-           (fail val '(expected "an immutable vector" given: "~e") val))]
-        [(eq? immutable #f)
-         (when (immutable? val)
-           (fail val '(expected "a mutable vector" given: "~e") val))]
-        [else (void)])
-      (when first-order?
-        (let loop ([n 0])
-          (cond
-            [(= n (vector-length val))
-             (void)]
-            [else
-             (define e (vector-ref val n))
-             (unless (contract-first-order-passes? elem-ctc e)
-               (fail val '(expected: "~s for element ~s" given: "~e") (contract-name elem-ctc) n e))
-             (contract-first-order-try-less-hard (loop (+ n 1)))])))
-      #t)))
+(define (check-vectorof elem-ctc immutable val blame neg-party first-order? raise-blame?)
+  (and
+   (do-check-vectorof val immutable blame neg-party raise-blame?)
+   (if first-order?
+       (let loop ([n 0])
+         (cond
+           [(= n (vector-length val)) #t]
+           [else
+            (define e (vector-ref val n))
+            (cond
+              [(contract-first-order-passes? elem-ctc e)
+               (contract-first-order-try-less-hard (loop (+ n 1)))]
+              [raise-blame?
+               (raise-blame-error
+                blame
+                #:missing-party neg-party
+                val
+                '(expected: "~s for element ~s" given: "~e")
+                (contract-name elem-ctc)
+                n
+                e)]
+              [else #f])]))
+       #t)))
 
 (define (check-late-neg-vectorof c)
   (define immutable (base-vectorof-immutable c))
@@ -103,10 +98,10 @@
                           val)])))
 
 (define (vectorof-first-order ctc)
-  (let ([check (check-vectorof ctc)])
+  (let ([elem-ctc (base-vectorof-elem ctc)]
+        [immutable (base-vectorof-immutable ctc)])
     (λ (val)
-      (let/ec return
-        (check val (λ _ (return #f)) #t)))))
+      (check-vectorof elem-ctc immutable val #f #f #t #f))))
 
 (define (vectorof-stronger this that)
   (define this-elem (base-vectorof-elem this))
@@ -157,107 +152,161 @@
 
 (define (blame-add-element-of-context blame #:swap? [swap? #f])
   (blame-add-context blame "an element of" #:swap? swap?))
-    
-(define (vectorof-late-neg-ho-projection chaperone-or-impersonate-vector)
+
+(define (vectorof-collapsible-late-neg-ho-projection chap-not-imp?)
+  (define chaperone-or-impersonate-vector
+    (if chap-not-imp? chaperone-vector impersonate-vector))
   (λ (ctc)
     (define elem-ctc (base-vectorof-elem ctc))
-    (define immutable (base-vectorof-immutable ctc))
+    (define flat-subcontract? (flat-contract-struct? elem-ctc))
     (define eager (base-vectorof-eager ctc))
-    (define check (check-vectorof ctc))
+    (define immutable (base-vectorof-immutable ctc))
+    (define vfp (get/build-collapsible-late-neg-projection elem-ctc))
     (λ (blame)
       (define pos-blame (blame-add-element-of-context blame))
       (define neg-blame (blame-add-element-of-context blame #:swap? #t))
-      (define vfp (get/build-late-neg-projection elem-ctc))
-      (define-values (filled? elem-pos-proj elem-neg-proj)
-        (contract-pos/neg-doubling (vfp pos-blame) (vfp neg-blame)))
-      (define-values (checked-ref checked-set)
+      (define-values (filled? maybe-elem-pos-proj maybe-c-c-pos maybe-elem-neg-proj maybe-c-c-neg)
+        (contract-pos/neg-doubling.2 (vfp pos-blame) (vfp neg-blame)))
+      (define-values (fetch-tc-pos fetch-tc-neg)
+        (cond
+          [filled? (values #f #f)]
+          [else
+           (define tc-pos (make-thread-cell #f))
+           (define tc-neg (make-thread-cell #f))
+           (define (fetch-from-tc tc maybe-elem-proj maybe-c-c)
+             (cond
+               [(thread-cell-ref tc) => values]
+               [else
+                (define-values (elem-proj c-c) (maybe-elem-proj))
+                (define pr (cons elem-proj c-c))
+                (thread-cell-set! tc pr)
+                pr]))
+           (values (λ () (fetch-from-tc tc-pos maybe-elem-pos-proj maybe-c-c-pos))
+                   (λ () (fetch-from-tc tc-neg maybe-elem-neg-proj maybe-c-c-neg)))]))
+      (define c-c-vector
+        (cond
+          [filled? (build-collapsible-vector maybe-c-c-pos maybe-c-c-neg ctc blame chap-not-imp?)]
+          [else
+           (build-doubling-collapsible-vector (λ () (cdr (fetch-tc-pos)))
+                                              (λ () (cdr (fetch-tc-neg)))
+                                              ctc blame chap-not-imp?)]))
+
+      (define checked-ref
         (cond
           [filled?
-           (define checked-ref (λ (neg-party)
-                                 (define blame+neg-party (cons pos-blame neg-party))
-                                 (λ (vec i val)
-                                   (with-contract-continuation-mark
-                                       blame+neg-party
-                                     (elem-pos-proj val neg-party)))))
-           (define checked-set (λ (neg-party)
-                                 (define blame+neg-party (cons neg-blame neg-party))
-                                 (λ (vec i val)
-                                   (with-contract-continuation-mark
-                                       blame+neg-party
-                                     (elem-neg-proj val neg-party)))))
-           (values checked-ref checked-set)]
+           (λ (neg-party)
+             (define blame+neg-party (cons pos-blame neg-party))
+             (λ (vec i val)
+               (with-contract-continuation-mark
+                   blame+neg-party
+                 (maybe-elem-pos-proj val neg-party))))]
           [else
-           (define ref-tc (make-thread-cell #f))
-           (define set-tc (make-thread-cell #f))
-           (define checked-ref (λ (neg-party)
-                                 (define blame+neg-party (cons pos-blame neg-party))
-                                 (λ (vec i val)
-                                   (with-contract-continuation-mark
-                                       blame+neg-party
-                                     (define real-elem-pos-proj
-                                       (cond
-                                         [(thread-cell-ref ref-tc) => values]
-                                         [else
-                                          (define real-elem-pos-proj (elem-pos-proj))
-                                          (thread-cell-set! ref-tc real-elem-pos-proj)
-                                          real-elem-pos-proj]))
-                                     (real-elem-pos-proj val neg-party)))))
-           (define checked-set (λ (neg-party)
-                                 (define blame+neg-party (cons neg-blame neg-party))
-                                 (λ (vec i val)
-                                   (with-contract-continuation-mark
-                                       blame+neg-party
-                                     (define real-elem-neg-proj
-                                       (cond
-                                         [(thread-cell-ref set-tc) => values]
-                                         [else
-                                          (define real-elem-neg-proj (elem-neg-proj))
-                                          (thread-cell-set! set-tc real-elem-neg-proj)
-                                          real-elem-neg-proj]))
-                                     (real-elem-neg-proj val neg-party)))))
-           (values checked-ref checked-set)]))
-      (cond
-        [(flat-contract? elem-ctc)
-         (define p? (flat-contract-predicate elem-ctc))
-         (λ (val neg-party)
-           (define (raise-blame val . args) 
-             (apply raise-blame-error blame #:missing-party neg-party val args))
-           (check val raise-blame #f)
-           ;; avoid traversing large vectors
-           ;; unless `eager` is specified
-           (cond
-             [(and (or (equal? eager #t)
-                       (and eager (<= (vector-length val) eager)))
-                   (immutable? val)
-                   (not (chaperone? val)))
-              (for ([e (in-vector val)])
-                (unless (p? e)
-                  (elem-pos-proj e neg-party)))
-              val]
-             [else
-              (chaperone-or-impersonate-vector
-               val
-               (checked-ref neg-party)
-               (checked-set neg-party)
-               impersonator-prop:contracted ctc
-               impersonator-prop:blame (blame-add-missing-party blame neg-party))]))]
-        [else
-          (λ (val neg-party)
-           (define (raise-blame val . args) 
-             (apply raise-blame-error blame #:missing-party neg-party val args))
-           (check val raise-blame #f)
-           (cond
-             [(and (immutable? val) (not (chaperone? val)))
-              (vector->immutable-vector
-               (for/vector #:length (vector-length val) ([e (in-vector val)])
-                 (elem-pos-proj e neg-party)))]
-             [else
-              (chaperone-or-impersonate-vector
-               val
-               (checked-ref neg-party)
-               (checked-set neg-party)
-               impersonator-prop:contracted ctc
-               impersonator-prop:blame (blame-add-missing-party blame neg-party))]))]))))
+           (λ (neg-party)
+             (define blame+neg-party (cons pos-blame neg-party))
+             (λ (vec i val)
+               (with-contract-continuation-mark
+                   blame+neg-party
+                 (define elem-pos-proj (car (fetch-tc-pos)))
+                 (elem-pos-proj val neg-party))))]))
+      (define checked-set
+        (cond
+          [filled?
+           (λ (neg-party)
+             (define blame+neg-party (cons neg-blame neg-party))
+             (λ (vec i val)
+               (with-contract-continuation-mark
+                   blame+neg-party
+                 (maybe-elem-neg-proj val neg-party))))]
+          [else
+           (λ (neg-party)
+             (define blame+neg-party (cons neg-blame neg-party))
+             (λ (vec i val)
+               (with-contract-continuation-mark
+                   blame+neg-party
+                 (define elem-neg-proj (car (fetch-tc-neg)))
+                 (elem-neg-proj val neg-party))))]))
+      (define p? (and (flat-contract-struct? elem-ctc)
+                      (flat-contract-predicate elem-ctc)))
+      (define late-neg-proj
+        (λ (val neg-party)
+          (check-vectorof elem-ctc immutable val blame neg-party #f #t)
+          (define immutable-non-chaperone?
+            (and (immutable? val) (not (chaperone? val))))
+          ;; avoid traversing large vectors
+          ;; unless `eager` is specified
+          (cond
+            [(and flat-subcontract?
+                  immutable-non-chaperone?
+                  (or (equal? eager #t)
+                      (and eager (<= (vector-length val) eager))))
+             (define elem-pos-proj (if filled?
+                                       maybe-elem-pos-proj
+                                       (car (fetch-tc-pos))))
+             (for ([e (in-vector val)])
+               (unless (p? e)
+                 (elem-pos-proj e neg-party)))
+             val]
+            [(and (not flat-subcontract?) immutable-non-chaperone?)
+             (define elem-pos-proj (if filled?
+                                       maybe-elem-pos-proj
+                                       (car (fetch-tc-pos))))
+             (vector->immutable-vector
+              (for/vector #:length (vector-length val) ([e (in-vector val)])
+                (elem-pos-proj e neg-party)))]
+            [else
+             (define old-c-c-prop (get-impersonator-prop:collapsible val #f))
+             (define safe-for-c-c?
+               (if old-c-c-prop
+                   (and (collapsible-property? old-c-c-prop)
+                        (eq? (collapsible-property-ref old-c-c-prop) val))
+                   (not (impersonator? val))))
+             (define wrapper-count
+               (if (collapsible-count-property? old-c-c-prop)
+                   (collapsible-count-property-count old-c-c-prop)
+                   0))
+             (cond
+               [(not safe-for-c-c?)
+                (chaperone-or-impersonate-vector
+                 val
+                 (checked-ref neg-party)
+                 (checked-set neg-party)
+                 impersonator-prop:contracted ctc
+                 impersonator-prop:blame (cons blame neg-party))]
+               [(wrapper-count . >= . COLLAPSIBLE-LIMIT)
+                (vector-enter-collapsible-mode/collapse
+                 c-c-vector
+                 val
+                 neg-party
+                 old-c-c-prop
+                 chap-not-imp?)]
+               [(collapsible-wrapper-property? old-c-c-prop)
+                (vector-enter-collapsible-mode/continue
+                 c-c-vector
+                 val
+                 neg-party
+                 (collapsible-property-c-c old-c-c-prop)
+                 (collapsible-property-neg-party old-c-c-prop)
+                 (collapsible-wrapper-property-checking-wrapper old-c-c-prop)
+                 chap-not-imp?)]
+               [else
+                (define c-c-prop
+                  (collapsible-count-property
+                   c-c-vector
+                   neg-party
+                   #f
+                   (add1 wrapper-count)
+                   (or old-c-c-prop val)))
+                (define wrapped
+                  (chaperone-or-impersonate-vector
+                   val
+                   (checked-ref neg-party)
+                   (checked-set neg-party)
+                   impersonator-prop:collapsible c-c-prop))
+                (set-collapsible-property-ref! c-c-prop wrapped)
+                wrapped])])))
+      (values
+       late-neg-proj
+       c-c-vector))))
 
 (define-values (prop:neg-blame-party prop:neg-blame-party? prop:neg-blame-party-get)
   (make-impersonator-property 'prop:neg-blame-party))
@@ -270,7 +319,7 @@
    #:first-order vectorof-first-order
    #:equivalent vectorof-equivalent
    #:stronger vectorof-stronger
-   #:late-neg-projection (vectorof-late-neg-ho-projection chaperone-vector)))
+   #:collapsible-late-neg-projection (vectorof-collapsible-late-neg-ho-projection #t)))
 
 (define-struct (impersonator-vectorof base-vectorof) ()
   #:property prop:custom-write custom-write-property-proc
@@ -280,7 +329,7 @@
    #:first-order vectorof-first-order
    #:equivalent vectorof-equivalent
    #:stronger vectorof-stronger
-   #:late-neg-projection (vectorof-late-neg-ho-projection impersonate-vector)))
+   #:collapsible-late-neg-projection (vectorof-collapsible-late-neg-ho-projection #f)))
 
 (define-syntax (wrap-vectorof stx)
   (syntax-case stx ()
@@ -331,8 +380,6 @@
 (define/subexpression-pos-prop (vector-immutableof c)
   (vectorof c #:immutable #t))
 
-(define-struct base-vector/c (elems immutable))
-
 (define (vector/c-name c)
   (let ([immutable (base-vector/c-immutable c)])
     (apply build-compound-type-name 'vector/c
@@ -346,32 +393,6 @@
                 (list '#:immutable immutable)
                 null)))))
 
-(define (check-vector/c ctc val blame neg-party)
-  (define elem-ctcs (base-vector/c-elems ctc))
-  (define immutable (base-vector/c-immutable ctc))
-  (unless (vector? val)
-    (raise-blame-error blame #:missing-party neg-party val
-                       '(expected: "a vector" given: "~e") val))
-  (cond
-    [(eq? immutable #t)
-     (unless (immutable? val)
-       (raise-blame-error blame #:missing-party neg-party val
-                          '(expected: "an immutable vector" given: "~e")
-                          val))]
-    [(eq? immutable #f)
-     (when (immutable? val)
-       (raise-blame-error blame #:missing-party neg-party val
-                          '(expected: "a mutable vector" given: "~e")
-                          val))]
-    [else (void)])
-  (define elem-count (length elem-ctcs))
-  (unless (= (vector-length val) elem-count)
-    (raise-blame-error blame #:missing-party neg-party val
-                       '(expected: "a vector of ~a element~a" given: "~e")
-                       elem-count
-                       (if (= elem-count 1) "" "s") 
-                       val)))
-
 (define (vector/c-first-order ctc)
   (define elem-ctcs (base-vector/c-elems ctc))
   (define immutable (base-vector/c-immutable ctc))
@@ -442,88 +463,184 @@
    #:stronger vector/c-stronger
    #:equivalent vector/c-equivalent
    #:late-neg-projection
-   (λ (ctc) 
+   (λ (ctc)
+     (define elems (base-vector/c-elems ctc))
+     (define immutable (base-vector/c-immutable ctc))
      (λ (blame) 
        (define blame+ctxt (blame-add-element-of-context blame))
        (define val+np-acceptors
-         (for/list ([c (in-list (base-vector/c-elems ctc))])
+         (for/list ([c (in-list elems)])
            ((get/build-late-neg-projection c) blame+ctxt)))
        (λ (val neg-party)
-         (check-vector/c ctc val blame neg-party)
+         (check-vector/c val blame immutable (length elems) neg-party)
          (for ([e (in-vector val)]
                [p (in-list val+np-acceptors)])
            (p e neg-party))
          val)))))
 
-(define (vector/c-ho-late-neg-projection vector-wrapper)
+(define (vector/c-collapsible-late-neg-ho-projection chap-not-imp?)
+  (define vector-wrapper (if chap-not-imp? chaperone-vector impersonate-vector))
   (λ (ctc)
-     (let ([elem-ctcs (base-vector/c-elems ctc)]
-           [immutable (base-vector/c-immutable ctc)])
-       (λ (blame)
-         (define-values (filled? maybe-elem-pos-projs maybe-elem-neg-projs)
-           (contract-pos/neg-doubling 
-            (for/vector #:length (length elem-ctcs)
-              ([c (in-list elem-ctcs)]
-               [i (in-naturals)])
-              ((get/build-late-neg-projection c)
-               (blame-add-context blame (nth-element-of i))))
-            (for/vector #:length (length elem-ctcs)
-              ([c (in-list elem-ctcs)]
-               [i (in-naturals)])
-              ((get/build-late-neg-projection c)
-               (blame-add-context blame (nth-element-of i) #:swap? #t)))))
-         (cond
-           [filled?
-            (λ (val neg-party)
-              (check-vector/c ctc val blame neg-party)
-              (define blame+neg-party (cons blame neg-party))
-              (if (and (immutable? val) (not (chaperone? val)))
-                  (apply vector-immutable
-                         (for/list ([e (in-vector val)]
-                                    [i (in-naturals)])
-                           ((vector-ref maybe-elem-pos-projs i) e neg-party)))
-                  (vector-wrapper
-                   val
-                   (λ (vec i val)
-                     (with-contract-continuation-mark
-                         blame+neg-party
-                       ((vector-ref maybe-elem-pos-projs i) val neg-party)))
-                   (λ (vec i val)
-                     (with-contract-continuation-mark
-                         blame+neg-party
-                       ((vector-ref maybe-elem-neg-projs i) val neg-party)))
-                   impersonator-prop:contracted ctc
-                   impersonator-prop:blame blame)))]
-           [else
-            (define pos-tc (make-thread-cell #f))
-            (define neg-tc (make-thread-cell #f))
-            (define (get-projs tc get-ele-projs)
-              (cond
-                [(thread-cell-ref tc) => values]
-                [else
-                 (define projs (get-ele-projs))
-                 (thread-cell-set! tc projs)
-                 projs]))
-            (λ (val neg-party)
-              (check-vector/c ctc val blame neg-party)
-              (define blame+neg-party (cons blame neg-party))
-              (if (and (immutable? val) (not (chaperone? val)))
-                  (apply vector-immutable
-                         (for/list ([e (in-vector val)]
-                                    [i (in-naturals)])
-                           ((vector-ref (get-projs pos-tc maybe-elem-pos-projs) i) e neg-party)))
-                  (vector-wrapper
-                   val
-                   (λ (vec i val)
-                     (with-contract-continuation-mark
-                         blame+neg-party
-                       ((vector-ref (get-projs pos-tc maybe-elem-pos-projs) i) val neg-party)))
-                   (λ (vec i val)
-                     (with-contract-continuation-mark
-                         blame+neg-party
-                       ((vector-ref (get-projs neg-tc maybe-elem-neg-projs) i) val neg-party)))
-                   impersonator-prop:contracted ctc
-                   impersonator-prop:blame blame)))])))))
+    (define elem-ctcs (base-vector/c-elems ctc))
+    (define immutable (base-vector/c-immutable ctc))
+    (define elems-length (length elem-ctcs))
+    (define selnps
+      (for/list ([elem-ctc (in-list elem-ctcs)])
+        (get/build-collapsible-late-neg-projection elem-ctc)))
+    (λ (blame)
+      (define-values (filled? maybe-elem-pos-projs maybe-c-c-poss maybe-elem-neg-projs maybe-c-c-negs)
+        (contract-pos/neg-doubling.2
+         (let ()
+           (define elem-pos-projs (make-vector elems-length #f))
+           (define elem-c-c-poss (make-vector elems-length #f))
+           (for ([selnp (in-list selnps)]
+                 [i (in-naturals)])
+             (define pos-blame (blame-add-context blame (nth-element-of i)))
+             (define-values (elem-pos-proj elem-c-c-pos) (selnp pos-blame))
+             (vector-set! elem-pos-projs i elem-pos-proj)
+             (vector-set! elem-c-c-poss i elem-c-c-pos))
+           (values elem-pos-projs elem-c-c-poss))
+         (let ()
+           (define elem-neg-projs (make-vector elems-length #f))
+           (define elem-c-c-negs (make-vector elems-length #f))
+           (for ([selnp (in-list selnps)]
+                 [i (in-naturals)])
+             (define neg-blame (blame-add-context blame (nth-element-of i)
+                                                  #:swap? #t))
+             (define-values (elem-neg-proj elem-c-c-neg) (selnp neg-blame))
+             (vector-set! elem-neg-projs i elem-neg-proj)
+             (vector-set! elem-c-c-negs i elem-c-c-neg))
+           (values elem-neg-projs elem-c-c-negs))))
+
+      (define-values (fetch-tc-pos fetch-tc-neg)
+        (cond
+          [filled? (values (void) (void))]
+          [else
+           (define tc-pos (make-thread-cell #f))
+           (define tc-neg (make-thread-cell #f))
+           (values (λ ()
+                     (cond
+                       [(thread-cell-ref tc-pos) => values]
+                       [else
+                        (define-values (elem-pos-projs maybe-c-c-pos) (maybe-elem-pos-projs))
+                        (define pr (cons elem-pos-projs maybe-c-c-pos))
+                        (thread-cell-set! tc-pos pr)
+                        pr]))
+                   (λ ()
+                     (cond
+                       [(thread-cell-ref tc-neg) => values]
+                       [else
+                        (define-values (elem-neg-projs maybe-c-c-neg) (maybe-elem-neg-projs))
+                        (define pr (cons elem-neg-projs maybe-c-c-neg))
+                        (thread-cell-set! tc-neg pr)
+                        pr])))]))
+      (define c-c-vector
+        (cond
+          [filled?
+           (build-collapsible-vector maybe-c-c-poss maybe-c-c-negs ctc blame chap-not-imp?)]
+          [else
+           (build-doubling-collapsible-vector (λ () (cdr (fetch-tc-pos)))
+                                              (λ () (cdr (fetch-tc-neg)))
+                                              ctc blame chap-not-imp?)]))
+
+      (define chaperone-get-proc
+        (cond
+          [filled?
+           (λ (neg-party blame+neg-party)
+             (λ (vec i val)
+               (with-contract-continuation-mark
+                   blame+neg-party
+                 ((vector-ref maybe-elem-pos-projs i) val neg-party))))]
+          [else
+           (λ (neg-party blame+neg-party)
+             (λ (vec i val)
+               (with-contract-continuation-mark
+                   blame+neg-party
+                 (define elem-pos-projs (car (fetch-tc-pos)))
+                 ((vector-ref elem-pos-projs i) val neg-party))))]))
+      (define chaperone-set-proc
+        (cond
+          [filled?
+           (λ (neg-party blame+neg-party)
+             (λ (vec i val)
+               (with-contract-continuation-mark
+                   blame+neg-party
+                 ((vector-ref maybe-elem-neg-projs i) val neg-party))))]
+          [else
+           (λ (neg-party blame+neg-party)
+             (λ (vec i val)
+               (with-contract-continuation-mark
+                   blame+neg-party
+                 (define elem-neg-projs (car (fetch-tc-neg)))
+                 ((vector-ref elem-neg-projs i) val neg-party))))]))
+      
+      (define late-neg-proj
+        (λ (val neg-party)
+          (define old-c-c-prop (get-impersonator-prop:collapsible val #f))
+          (define safe-for-c-c
+            (if old-c-c-prop
+                (and (collapsible-property? old-c-c-prop)
+                     (eq? (collapsible-property-ref old-c-c-prop) val))
+                (not (impersonator? val))))
+          (define wrapper-count
+            (if (collapsible-count-property? old-c-c-prop)
+                (collapsible-count-property-count old-c-c-prop)
+                0))
+          (check-vector/c val blame immutable elems-length neg-party)
+          (define blame+neg-party (cons blame neg-party))
+          (cond
+            [(and (immutable? val) (not (chaperone? val)))
+             (define elem-pos-projs
+               (if filled?
+                   maybe-elem-pos-projs
+                   (car (fetch-tc-pos))))
+             (apply vector-immutable
+                    (for/list ([i (in-naturals)]
+                               [elem-val (in-vector val)])
+                      ((vector-ref elem-pos-projs i) elem-val neg-party)))]
+            [(not safe-for-c-c)
+             (vector-wrapper
+              val
+              (chaperone-get-proc neg-party blame+neg-party)
+              (chaperone-set-proc neg-party blame+neg-party)
+              ;; TODO: should this be a collapsible property instead??
+              impersonator-prop:contracted ctc
+              impersonator-prop:blame blame+neg-party)]
+            [(wrapper-count . >= . COLLAPSIBLE-LIMIT)
+             (vector-enter-collapsible-mode/collapse
+              c-c-vector
+              val
+              neg-party
+              old-c-c-prop
+              chap-not-imp?)]
+            [(collapsible-wrapper-property? old-c-c-prop)
+             (vector-enter-collapsible-mode/continue
+              c-c-vector
+              val
+              neg-party
+              (collapsible-property-c-c old-c-c-prop)
+              (collapsible-property-neg-party old-c-c-prop)
+              (collapsible-wrapper-property-checking-wrapper old-c-c-prop)
+              chap-not-imp?)]
+            [else
+             (define c-c-prop
+               (collapsible-count-property
+                c-c-vector
+                neg-party
+                #f
+                (add1 wrapper-count)
+                (or old-c-c-prop val)))
+             (define wrapped
+               (vector-wrapper
+                val
+                (chaperone-get-proc neg-party blame+neg-party)
+                (chaperone-set-proc neg-party blame+neg-party)
+                impersonator-prop:collapsible c-c-prop))
+             (set-collapsible-property-ref! c-c-prop wrapped)
+             wrapped])))
+      (values
+       late-neg-proj
+       c-c-vector))))
 
 (define-struct (chaperone-vector/c base-vector/c) ()
   #:property prop:custom-write custom-write-property-proc
@@ -532,8 +649,8 @@
    #:name vector/c-name
    #:first-order vector/c-first-order
    #:stronger vector/c-stronger
-   #:equivalent vector/c-equivalent
-   #:late-neg-projection (vector/c-ho-late-neg-projection chaperone-vector)))
+   #:collapsible-late-neg-projection (vector/c-collapsible-late-neg-ho-projection #t)
+   #:equivalent vector/c-equivalent))
 
 (define-struct (impersonator-vector/c base-vector/c) ()
   #:property prop:custom-write custom-write-property-proc
@@ -542,8 +659,8 @@
    #:name vector/c-name
    #:first-order vector/c-first-order
    #:stronger vector/c-stronger
-   #:equivalent vector/c-equivalent
-   #:late-neg-projection (vector/c-ho-late-neg-projection impersonate-vector)))
+   #:collapsible-late-neg-projection (vector/c-collapsible-late-neg-ho-projection #f)
+   #:equivalent vector/c-equivalent))
 
 (define-syntax (wrap-vector/c stx)
   (syntax-case stx ()
diff --git a/racket/collects/racket/private/class-c-old.rkt b/racket/collects/racket/private/class-c-old.rkt
index 62f45c5541..b72deb5c52 100644
--- a/racket/collects/racket/private/class-c-old.rkt
+++ b/racket/collects/racket/private/class-c-old.rkt
@@ -10,7 +10,8 @@
          "../contract/combinator.rkt"
          (only-in "../contract/private/arrow-val-first.rkt" ->-internal ->*-internal)
          (only-in "../contract/private/case-arrow.rkt" case->-internal)
-         (only-in "../contract/private/arr-d.rkt" ->d-internal))
+         (only-in "../contract/private/arr-d.rkt" ->d-internal)
+         (submod "../contract/private/collapsible-common.rkt" properties))
 
 (provide make-class/c class/c-late-neg-proj
          blame-add-method-context blame-add-field-context blame-add-init-context