diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl
index bcd9a5e83d..8bed7d97d8 100644
--- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl
+++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl
@@ -2374,6 +2374,43 @@ of the @tech{blame object} and the missing party should be used instead.
 @history[#:added "6.4.0.4"]
 }
 
+@defform[(contract-pos/neg-doubling e1 e2)]{
+
+ Some contract combinators need to build projections for
+ subcontracts with both regular and @racket[blame-swap]ed
+ versions of the blame that they are given in order to check
+ both access and mutations (e.g., @racket[vector/c] and
+ @racket[vectorof]). In the case that such combinators are
+ nested deeply inside each other, there is a potential for an
+ exponential explosion of nested projections being built.
+
+ To avoid that explosion, wrap each of the calls to the
+ blame-accepting portion of the combinator in
+ @racket[contract-pos/neg-doubling]. It returns three values.
+ The first is a boolean, indicating how to interpret the
+ other two results. If the boolean is @racket[#t], then the
+ other two results are the values of @racket[e1] and
+ @racket[e2] and we are not too deep in the nesting. If the
+ boolean is @racket[#f], then we have passed a threshold and
+ it is not safe to evaluate @racket[e1] and @racket[e2] yet,
+ as we are in danger of running into the exponential
+ slowdown. In that case, the last two results are thunks
+ that, when invoked, compute the values of @racket[e1] and
+ @racket[e2].
+
+ As an example, @racket[vectorof] uses
+ @racket[contract-pos/neg-doubling] wrapping its two calls to
+ the blame-accepting part of the projection for its
+ subcontract. When it receives a @racket[#f] as that first
+ boolean, it does not invoke the thunks right away, but waits
+ until the interposition procedure that it attaches to the
+ chaperoned vector is called. Then it invokes them (and caches
+ the result). This delays the construction of the projections
+ until they are actually needed, avoiding the exponential blowup.
+
+ @history[#:added "6.90.0.27"]
+}
+
 @subsection{Blame Objects}
 
 This section describes @deftech{blame objects} and operations on them.
diff --git a/pkgs/racket-test/tests/racket/contract/box.rkt b/pkgs/racket-test/tests/racket/contract/box.rkt
index d779ee603a..91ca9da9c9 100644
--- a/pkgs/racket-test/tests/racket/contract/box.rkt
+++ b/pkgs/racket-test/tests/racket/contract/box.rkt
@@ -75,6 +75,27 @@
    'box/c12
    '(set-box! (contract (box/c integer?) (box 1) 'pos 'neg) 1.5))
 
+  (test/pos-blame
+   'box/c13
+   '(let ()
+      (define N 18)
+
+      (define c
+        (for/fold ([c (-> integer? integer?)])
+                  ([i (in-range N)])
+          (box/c c)))
+
+      (define val
+        (for/fold ([val 5])
+                  ([i (in-range N)])
+          (box val)))
+
+      (define cval (contract c val 'pos 'neg))
+
+      (for/fold ([val cval])
+                ([i (in-range N)])
+        (unbox val))))
+  
   ;; contract-stronger? tests
   (contract-eval '(require (only-in racket/contract/combinator contract-stronger?)))
 
diff --git a/pkgs/racket-test/tests/racket/contract/class.rkt b/pkgs/racket-test/tests/racket/contract/class.rkt
index 327090a6ed..9c8a421e50 100644
--- a/pkgs/racket-test/tests/racket/contract/class.rkt
+++ b/pkgs/racket-test/tests/racket/contract/class.rkt
@@ -1593,6 +1593,31 @@
                  (inherit-field f)
                  (define/public (m) f))])
       (send (new d%) m)))
+
+  (test/pos-blame
+   'inherit-field-lots-of-wrappers
+   '(let ()
+      (define N 40)
+
+      (define c
+        (for/fold ([c (-> integer? integer?)])
+                  ([i (in-range N)])
+          (class/c (inherit-field [fld c]))))
+
+      (define val
+        (for/fold ([val 5])
+                  ([i (in-range N)])
+          (class object% (field [fld val]) (super-new))))
+
+      (define cval (contract c val 'pos 'neg))
+
+      (for/fold ([val cval])
+                ([i (in-range N)])
+        (send (new (class val
+                     (super-new)
+                     (inherit-field fld)
+                     (define/public (m) fld)))
+              m))))
   
   (test/spec-passed
    'class/c-higher-order-override-1
@@ -2087,6 +2112,49 @@
                              'somethingelse1 'somethingelse2)
                    'pos 'neg)
          [x 2]))
+
+  (test/pos-blame
+   'class/c-deep.1
+   '(let ()
+      (define N 40)
+
+      (define c
+        (for/fold ([c (-> integer? integer?)])
+                  ([i (in-range N)])
+          (class/c (field [fld c]))))
+
+      (define v
+        (for/fold ([v 1])
+                  ([i (in-range N)])
+          (class object%
+            (field [fld v])
+            (super-new))))
+
+      (let loop ([v (contract c v 'pos 'neg)])
+        (loop (get-field fld (new v))))))
+
+  (test/neg-blame
+   'class/c-deep.2
+   '(let ()
+      (define N 40)
+
+      (define c
+        (for/fold ([c (-> integer? integer?)])
+                  ([i (in-range N)])
+          (class/c (field [fld c]))))
+
+      (define v
+        (for/fold ([v 1])
+                  ([i (in-range N)])
+          (class object%
+            (field [fld v])
+            (super-new))))
+
+      (let loop ([v (contract c v 'pos 'neg)]
+                 [i N])
+        (cond
+          [(= i 1) (set-field! fld (new v) 'not-a-proc)]
+          [else (loop (get-field fld (new v)) (- i 1))]))))
   
   (test/spec-passed/result
    'class-field-accessor1
diff --git a/pkgs/racket-test/tests/racket/contract/hash.rkt b/pkgs/racket-test/tests/racket/contract/hash.rkt
index fac55229c8..ab0415528c 100644
--- a/pkgs/racket-test/tests/racket/contract/hash.rkt
+++ b/pkgs/racket-test/tests/racket/contract/hash.rkt
@@ -235,6 +235,21 @@
                      c-h))
    #t)
 
+  (test/pos-blame
+   'hash/c18
+   '(let ()
+      (define N 40)
+      (define c
+        (for/fold ([c (-> integer? integer?)])
+                  ([i (in-range N)])
+          (hash/c c integer?)))
+      (define h
+        (for/fold ([h 0])
+                  ([i (in-range N)])
+          (hash h i)))
+      (immutable? h)
+
+      (void (contract c h 'pos 'neg))))
   
   (test/pos-blame
    'hash/dc1
diff --git a/pkgs/racket-test/tests/racket/contract/object.rkt b/pkgs/racket-test/tests/racket/contract/object.rkt
index 6c4febe720..d24164816e 100644
--- a/pkgs/racket-test/tests/racket/contract/object.rkt
+++ b/pkgs/racket-test/tests/racket/contract/object.rkt
@@ -283,6 +283,51 @@
 
     (send x3 p)))
 
+  (test/pos-blame
+   'object/c-lots-of-wrapping.1
+   '(let ()
+      (define N 40)
+
+      (define c
+        (for/fold ([c (-> integer? integer?)])
+                  ([i (in-range N)])
+          (object/c (field [fld c]))))
+
+      (define o
+        (for/fold ([v 'not-a-proc])
+                  ([i (in-range N)])
+          (new
+           (class object%
+             (field [fld v])
+             (super-new)))))
+
+      (let loop ([o (contract c o 'pos 'neg)])
+        (loop (get-field fld o)))))
+
+  (test/neg-blame
+   'object/c-lots-of-wrapping.2
+   '(let ()
+      (define N 40)
+
+      (define c
+        (for/fold ([c (-> integer? integer?)])
+                  ([i (in-range N)])
+          (object/c (field [fld c]))))
+
+      (define o
+        (for/fold ([v add1])
+                  ([i (in-range N)])
+          (new
+           (class object%
+             (field [fld v])
+             (super-new)))))
+
+      (let loop ([o (contract c o 'pos 'neg)]
+                 [i N])
+        (cond
+          [(= i 1) (set-field! fld o 'not-a-proc)]
+          [else (loop (get-field fld o) (- i 1))]))))
+
   (test/spec-passed
    'object/c-just-check-existence
    '(contract (object/c m)
diff --git a/pkgs/racket-test/tests/racket/contract/vector.rkt b/pkgs/racket-test/tests/racket/contract/vector.rkt
index 9795638e93..2e9b3b7d19 100644
--- a/pkgs/racket-test/tests/racket/contract/vector.rkt
+++ b/pkgs/racket-test/tests/racket/contract/vector.rkt
@@ -86,6 +86,42 @@
    '(contract (vectorof integer? #:flat? #t)
               (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)))))
+
+  (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
@@ -126,6 +162,57 @@
                                (λ (vec i v) v))])
       (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)))))
+
+  (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))]))))
   
   (test/pos-blame
    'vector/c7
diff --git a/racket/collects/racket/contract/combinator.rkt b/racket/collects/racket/contract/combinator.rkt
index b7115e7a88..7f1b198303 100644
--- a/racket/collects/racket/contract/combinator.rkt
+++ b/racket/collects/racket/contract/combinator.rkt
@@ -105,7 +105,9 @@
              [-make-flat-contract make-flat-contract]
              [-build-chaperone-contract-property build-chaperone-contract-property]
              [-build-flat-contract-property build-flat-contract-property])
- skip-projection-wrapper?)
+ skip-projection-wrapper?
+
+ contract-pos/neg-doubling)
 
 (define skip-projection-wrapper? (make-parameter #f))
 
diff --git a/racket/collects/racket/contract/private/box.rkt b/racket/collects/racket/contract/private/box.rkt
index b6023a36c9..619f397e0f 100644
--- a/racket/collects/racket/contract/private/box.rkt
+++ b/racket/collects/racket/contract/private/box.rkt
@@ -137,29 +137,45 @@
     (define r-vfp (get/build-late-neg-projection elem-r-ctc))
     (λ (blame)
       (define box-blame (add-box-context blame))
-      (define pos-elem-r-proj (r-vfp box-blame))
-      (define neg-elem-w-proj (w-vfp (blame-swap box-blame)))
-      (λ (val neg-party)
-        (define blame+neg-party (cons blame neg-party))
-        (cond
-          [(check-box/c-np ctc val blame)
-           =>
-           (λ (f) (f neg-party))]
-          [else
-           (if (and (immutable? val) (not (chaperone? val)))
-               (box-immutable (pos-elem-r-proj (unbox val) neg-party))
-               (chaperone/impersonate-box 
-                val
-                (λ (b v)
-                  (with-contract-continuation-mark
-                   blame+neg-party
-                   (pos-elem-r-proj v neg-party)))
-                (λ (b v)
-                  (with-contract-continuation-mark
-                   blame+neg-party
-                   (neg-elem-w-proj v neg-party)))
-                impersonator-prop:contracted ctc
-                impersonator-prop:blame (blame-add-missing-party blame neg-party)))])))))
+      (define-values (filled? maybe-pos-elem-r-proj maybe-neg-elem-w-proj)
+        (contract-pos/neg-doubling (r-vfp box-blame)
+                                   (w-vfp (blame-swap box-blame))))
+      (define (make-val-np/proc pos-elem-r-proj neg-elem-w-proj)
+        (λ (val neg-party)
+          (define blame+neg-party (cons blame neg-party))
+          (cond
+            [(check-box/c-np ctc val blame)
+             =>
+             (λ (f) (f neg-party))]
+            [else
+             (if (and (immutable? val) (not (chaperone? val)))
+                 (box-immutable (pos-elem-r-proj (unbox val) neg-party))
+                 (chaperone/impersonate-box 
+                  val
+                  (λ (b v)
+                    (with-contract-continuation-mark
+                        blame+neg-party
+                      (pos-elem-r-proj v neg-party)))
+                  (λ (b v)
+                    (with-contract-continuation-mark
+                        blame+neg-party
+                      (neg-elem-w-proj v neg-party)))
+                  impersonator-prop:contracted ctc
+                  impersonator-prop:blame (blame-add-missing-party blame neg-party)))])))
+      (cond
+        [filled?
+         (make-val-np/proc maybe-pos-elem-r-proj maybe-neg-elem-w-proj)]
+        [else
+         (define tc (make-thread-cell #f))
+         (λ (val neg-party)
+           (cond
+             [(thread-cell-ref tc)
+              =>
+              (λ (f) (f val neg-party))]
+             [else
+              (define proc (make-val-np/proc (maybe-pos-elem-r-proj) (maybe-neg-elem-w-proj)))
+              (thread-cell-set! tc proc)
+              (proc val neg-party)]))]))))
 
 (define-struct (chaperone-box/c base-box/c) ()
   #:property prop:custom-write custom-write-property-proc
diff --git a/racket/collects/racket/contract/private/guts.rkt b/racket/collects/racket/contract/private/guts.rkt
index 98d6a471d7..f80d329b78 100644
--- a/racket/collects/racket/contract/private/guts.rkt
+++ b/racket/collects/racket/contract/private/guts.rkt
@@ -84,7 +84,9 @@
          n->th
 
          false/c-contract
-         true/c-contract)
+         true/c-contract
+
+         contract-pos/neg-doubling)
 
 (define (contract-custom-write-property-proc stct port mode)
   (define (write-prefix)
@@ -877,3 +879,20 @@
      [(2) "nd"]
      [(3) "rd"]
      [else "th"])))
+
+
+(define-syntax-rule
+  (contract-pos/neg-doubling e1 e2)
+  (contract-pos/neg-doubling/proc (λ () e1) (λ () e2)))
+(define doubling-cm-key (gensym 'racket/contract-doubling-mark))
+(define (contract-pos/neg-doubling/proc t1 t2)
+  (define depth
+    (or (continuation-mark-set-first (current-continuation-marks)
+                                     doubling-cm-key)
+        0))
+  (cond
+    [(> depth 5)
+     (values #f t1 t2)]
+    [else
+     (with-continuation-mark doubling-cm-key (+ depth 1)
+       (values #t (t1) (t2)))]))
\ No newline at end of file
diff --git a/racket/collects/racket/contract/private/hash.rkt b/racket/collects/racket/contract/private/hash.rkt
index cb3882580a..b7436e2880 100644
--- a/racket/collects/racket/contract/private/hash.rkt
+++ b/racket/collects/racket/contract/private/hash.rkt
@@ -81,9 +81,6 @@
 ;; ... --> boolean
 ;;  returns #t when it called raise-blame-error, #f otherwise
 (define (check-hash/c dom-ctc immutable flat? val blame neg-party) 
-  ;(define dom-ctc (base-hash/c-dom ctc))
-  ;(define immutable (base-hash/c-immutable ctc))
-  ;(define flat? (flat-hash/c? ctc))
   (cond
     [(hash? val)
      (cond
@@ -215,18 +212,46 @@
     (define dom-proc (get/build-late-neg-projection dom-ctc))
     (define rng-proc (get/build-late-neg-projection (base-hash/c-rng ctc)))
     (λ (blame)
-      (define pos-dom-proj (dom-proc (blame-add-key-context blame #f)))
-      (define neg-dom-proj (dom-proc (blame-add-key-context blame #t)))
-      (define pos-rng-proj (rng-proc (blame-add-value-context blame #f)))
-      (define neg-rng-proj (rng-proc (blame-add-value-context blame #t)))
-      (λ (val neg-party)
-        (cond
-          [(check-hash/c dom-ctc immutable flat? val blame neg-party)
-           val]
-          [else
-           (handle-the-hash val neg-party
-                            pos-dom-proj neg-dom-proj (λ (v) pos-rng-proj) (λ (v) neg-rng-proj)
-                            chaperone-or-impersonate-hash ctc blame)])))))
+      (define-values (dom-filled? maybe-pos-dom-proj maybe-neg-dom-proj)
+        (contract-pos/neg-doubling (dom-proc (blame-add-key-context blame #f))
+                                   (dom-proc (blame-add-key-context blame #t))))
+      (define-values (rng-filled? maybe-pos-rng-proj maybe-neg-rng-proj)
+        (contract-pos/neg-doubling (rng-proc (blame-add-value-context blame #f))
+                                   (rng-proc (blame-add-value-context blame #t))))
+      (cond
+        [(and dom-filled? rng-filled?)
+         (λ (val neg-party)
+           (cond
+             [(check-hash/c dom-ctc immutable flat? val blame neg-party)
+              val]
+             [else
+              (handle-the-hash val neg-party
+                               maybe-pos-dom-proj maybe-neg-dom-proj
+                               (λ (v) maybe-pos-rng-proj) (λ (v) maybe-neg-rng-proj)
+                               chaperone-or-impersonate-hash ctc blame)]))]
+        [else
+         (define tc (make-thread-cell #f))
+         (λ (val neg-party)
+           (define-values (pos-dom-proj neg-dom-proj pos-rng-proj neg-rng-proj)
+             (cond
+               [(thread-cell-ref tc)
+                =>
+                (λ (v) (values (vector-ref v 1) (vector-ref v 2) (vector-ref v 3) (vector-ref v 4)))]
+               [else
+                (define pos-dom-proj (maybe-pos-dom-proj))
+                (define neg-dom-proj (maybe-neg-dom-proj))
+                (define pos-rng-proj (maybe-pos-rng-proj))
+                (define neg-rng-proj (maybe-neg-rng-proj))
+                (thread-cell-set! tc (vector pos-dom-proj neg-dom-proj pos-rng-proj neg-rng-proj))
+                (values pos-dom-proj neg-dom-proj pos-rng-proj neg-rng-proj)]))
+           (cond
+             [(check-hash/c dom-ctc immutable flat? val blame neg-party)
+              val]
+             [else
+              (handle-the-hash val neg-party
+                               pos-dom-proj neg-dom-proj
+                               (λ (v) pos-rng-proj) (λ (v) neg-rng-proj)
+                               chaperone-or-impersonate-hash ctc blame)]))]))))
 
 (define (blame-add-key-context blame swap?) (blame-add-context blame "the keys of" #:swap? swap?))
 (define (blame-add-value-context blame swap?) (blame-add-context blame "the values of" #:swap? swap?))
diff --git a/racket/collects/racket/contract/private/vector.rkt b/racket/collects/racket/contract/private/vector.rkt
index 1069a103e5..9eac01a48f 100644
--- a/racket/collects/racket/contract/private/vector.rkt
+++ b/racket/collects/racket/contract/private/vector.rkt
@@ -147,7 +147,7 @@
 
 (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)
   (λ (ctc)
     (define elem-ctc (base-vectorof-elem ctc))
@@ -158,20 +158,54 @@
       (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 elem-pos-proj (vfp pos-blame))
-      (define elem-neg-proj (vfp neg-blame))
-      (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)))))
+      (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)
+        (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)]
+          [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))
@@ -181,35 +215,39 @@
            (check val raise-blame #f)
            ;; avoid traversing large vectors
            ;; unless `eager` is specified
-           (if (and (or (equal? eager #t)
-                        (and eager (<= (vector-length val) eager)))
-                    (immutable? val)
-                    (not (chaperone? val)))
-               (begin (for ([e (in-vector val)])
-                        (unless (p? e)
-                          (elem-pos-proj e neg-party)))
-                      val)
-               (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))))]
+           (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)
+          (λ (val neg-party)
            (define (raise-blame val . args) 
              (apply raise-blame-error blame #:missing-party neg-party val args))
            (check val raise-blame #f)
-           (if (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)))
-               (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))))]))))
+           (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))]))]))))
 
 (define-values (prop:neg-blame-party prop:neg-blame-party? prop:neg-blame-party-get)
   (make-impersonator-property 'prop:neg-blame-party))
@@ -250,7 +288,10 @@
           'racket/contract:contract
           (vector this-one (list #'vecof) null))))]))
 
-(define/subexpression-pos-prop (vectorof c #:immutable [immutable 'dont-care] #:flat? [flat? #f] #:eager [eager #t])
+(define/subexpression-pos-prop (vectorof c
+                                         #:immutable [immutable 'dont-care]
+                                         #:flat? [flat? #f]
+                                         #:eager [eager #t])
   (define ctc
     (if flat?
         (coerce-flat-contract 'vectorof c)
@@ -398,37 +439,71 @@
      (let ([elem-ctcs (base-vector/c-elems ctc)]
            [immutable (base-vector/c-immutable ctc)])
        (λ (blame)
-         (let ([elem-pos-projs (for/vector #:length (length elem-ctcs)
-                                 ([c (in-list elem-ctcs)]
-                                  [i (in-naturals)])
-                                 ((get/build-late-neg-projection c)
-                                  (blame-add-context blame (format "the ~a element of" (n->th i)))))]
-               [elem-neg-projs (for/vector #:length (length elem-ctcs)
-                                 ([c (in-list elem-ctcs)]
-                                  [i (in-naturals)])
-                                 ((get/build-late-neg-projection c)
-                                  (blame-add-context blame (format "the ~a element of" (n->th i))
-                                                     #:swap? #t)))])
-           (λ (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 elem-pos-projs i) e neg-party)))
-                 (vector-wrapper
-                  val
-                  (λ (vec i val)
-                    (with-contract-continuation-mark
-                     blame+neg-party
-                     ((vector-ref elem-pos-projs i) val neg-party)))
-                  (λ (vec i val)
-                    (with-contract-continuation-mark
-                     blame+neg-party
-                     ((vector-ref elem-neg-projs i) val neg-party)))
-                  impersonator-prop:contracted ctc
-                  impersonator-prop:blame 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 (format "the ~a element of" (n->th 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 (format "the ~a element of" (n->th 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-struct (chaperone-vector/c base-vector/c) ()
   #:property prop:custom-write custom-write-property-proc
diff --git a/racket/collects/racket/private/class-c-old.rkt b/racket/collects/racket/private/class-c-old.rkt
index 1e79749b0c..df2b31043c 100644
--- a/racket/collects/racket/private/class-c-old.rkt
+++ b/racket/collects/racket/private/class-c-old.rkt
@@ -177,27 +177,50 @@
                  [c (in-list (class/c-method-contracts ctc))])
         (and c
              ((contract-late-neg-projection c) (blame-add-method-context blame name)))))
-    
     (define external-field-projections
       (for/list ([f (in-list (class/c-fields ctc))]
                  [c (in-list (class/c-field-contracts ctc))])
         (define pos-blame (blame-add-field-context blame f #:swap? #f))
         (define neg-blame (blame-add-field-context blame f #:swap? #t))
-        (and c
-             (let ([p-pos ((contract-late-neg-projection c)
-                           pos-blame)]
-                   [p-neg ((contract-late-neg-projection c)
-                           neg-blame)])
-               (cons (lambda (x pos-party)
-                       (define blame+pos-party (cons pos-blame pos-party))
-                       (with-contract-continuation-mark
-                        blame+pos-party
+        (cond
+          [c
+           (define-values (filled? maybe-p-pos maybe-p-neg)
+             (contract-pos/neg-doubling ((contract-late-neg-projection c) pos-blame)
+                                        ((contract-late-neg-projection c) neg-blame)))
+           (cond
+             [filled?
+              (cons (lambda (x pos-party)
+                      (define blame+pos-party (cons pos-blame pos-party))
+                      (with-contract-continuation-mark
+                          blame+pos-party
+                        (maybe-p-pos x pos-party)))
+                    (lambda (x neg-party)
+                      (define blame+neg-party (cons neg-blame neg-party))
+                      (with-contract-continuation-mark
+                          blame+neg-party
+                        (maybe-p-neg x neg-party))))]
+             [else
+              (define tc-pos (make-thread-cell #f))
+              (define tc-neg (make-thread-cell #f))
+              (cons (lambda (x pos-party)
+                      (define blame+pos-party (cons pos-blame pos-party))
+                      (with-contract-continuation-mark
+                          blame+pos-party
+                        (define p-pos (or (thread-cell-ref tc-pos)
+                                          (let ([p-pos (maybe-p-pos)])
+                                            (thread-cell-set! tc-pos p-pos)
+                                            p-pos)))
                         (p-pos x pos-party)))
-                     (lambda (x neg-party)
-                       (define blame+neg-party (cons neg-blame neg-party))
-                       (with-contract-continuation-mark
-                        blame+neg-party
-                        (p-neg x neg-party))))))))
+                    (lambda (x neg-party)
+                      (define blame+neg-party (cons neg-blame neg-party))
+                      (with-contract-continuation-mark
+                          blame+neg-party
+                        (define p-neg (or (thread-cell-ref tc-neg)
+                                          (let ([p-neg (maybe-p-neg)])
+                                            (thread-cell-set! tc-neg p-neg)
+                                            p-neg)))
+                        (p-neg x neg-party))))])]
+          [else #f])))
     
     ;; zip the inits and contracts together for ordered selection
     (define inits+contracts 
@@ -439,20 +462,52 @@
     (define internal-field-projections
       (for/list ([f (in-list (internal-class/c-inherit-fields internal-ctc))]
                  [c (in-list (internal-class/c-inherit-field-contracts internal-ctc))])
-        (and c
-             (let* ([blame-acceptor (contract-late-neg-projection c)]
-                    [p-pos (blame-acceptor blame)]
-                    [p-neg (blame-acceptor bswap)])
-               (cons (lambda (x pos-party)
-                       (define blame+pos-party (cons blame pos-party))
-                       (with-contract-continuation-mark
-                        blame+pos-party
+        (cond
+          [c
+           (define blame-acceptor (contract-late-neg-projection c))
+           (define-values (filled? maybe-p-pos maybe-p-neg)
+             (contract-pos/neg-doubling (blame-acceptor blame)
+                                        (blame-acceptor bswap)))
+           (cond
+             [filled?
+              (cons (lambda (x pos-party)
+                      (define blame+pos-party (cons blame pos-party))
+                      (with-contract-continuation-mark
+                          blame+pos-party
+                        (maybe-p-pos x pos-party)))
+                    (lambda (x neg-party)
+                      (define blame+neg-party (cons blame neg-party))
+                      (with-contract-continuation-mark
+                          blame+neg-party
+                        (maybe-p-neg x neg-party))))]
+             [else
+              (define tc-pos (make-thread-cell #f))
+              (define tc-neg (make-thread-cell #f))
+              (cons (lambda (x pos-party)
+                      (define blame+pos-party (cons blame pos-party))
+                      (with-contract-continuation-mark
+                          blame+pos-party
+                        (define p-pos
+                          (cond
+                            [(thread-cell-ref tc-pos) => values]
+                            [else
+                             (define p-pos (maybe-p-pos))
+                             (thread-cell-set! tc-pos p-pos)
+                             p-pos]))
                         (p-pos x pos-party)))
-                     (lambda (x neg-party)
-                       (define blame+neg-party (cons blame neg-party))
-                       (with-contract-continuation-mark
-                        blame+neg-party
-                        (p-neg x neg-party))))))))
+                    (lambda (x neg-party)
+                      (define blame+neg-party (cons blame neg-party))
+                      (with-contract-continuation-mark
+                          blame+neg-party
+                        (define p-neg
+                          (cond
+                            [(thread-cell-ref tc-neg) => values]
+                            [else
+                             (define p-neg (maybe-p-neg))
+                             (thread-cell-set! tc-neg p-neg)
+                             p-neg]))
+                        (p-neg x neg-party))))])]
+          [else #f])))
     
     (define override-projections
       (for/list ([m (in-list (internal-class/c-overrides internal-ctc))]
@@ -1602,16 +1657,24 @@
          ((contract-late-neg-projection c) blame*)]
         [else #f])))
 
-  (define pos/neg-field-projs
-    (for/list ([f (in-list fields)]
-               [c (in-list field-contracts)])
-      (cond
-        [(just-check-existence? c) #f]
-        [else
-         (define prj (contract-late-neg-projection c))
-         (vector
-          (prj (blame-add-field-context blame f #:swap? #f))
-          (prj (blame-add-field-context blame f #:swap? #t)))])))
+  (define-values (filled? maybe-pos-field-projs maybe-neg-field-projs)
+    (contract-pos/neg-doubling
+     (for/list ([f (in-list fields)]
+                [c (in-list field-contracts)])
+       (cond
+         [(just-check-existence? c) #f]
+         [else
+          (define prj (contract-late-neg-projection c))
+          (prj (blame-add-field-context blame f #:swap? #f))]))
+     (for/list ([f (in-list fields)]
+                [c (in-list field-contracts)])
+       (cond
+         [(just-check-existence? c) #f]
+         [else
+          (define prj (contract-late-neg-projection c))
+          (prj (blame-add-field-context blame f #:swap? #t))]))))
+
+  (define tc (and (not filled?) (make-thread-cell #f)))
 
   (λ (cls neg-party)
   (let* ([name (class-name cls)]
@@ -1712,25 +1775,36 @@
           (when method-proj
             (define i (hash-ref method-ht m))
             (vector-set! meths i (make-method (method-proj (vector-ref meths i) neg-party) m))))))
-    
+
     ;; Handle external field contracts
     (unless (null? fields)
-      (for ([f (in-list fields)]
-            [c (in-list field-contracts)]
-            [pos/neg-field-proj (in-list pos/neg-field-projs)])
-        (unless (just-check-existence? c)
-          (define fi (hash-ref field-ht f))
-          (define p-pos (vector-ref pos/neg-field-proj 0))
-          (define p-neg (vector-ref pos/neg-field-proj 1))
-          (hash-set! field-ht f (field-info-extend-external fi
-                                                            (lambda args
-                                                              (with-contract-continuation-mark
-                                                               (cons blame neg-party)
-                                                               (apply p-pos args)))
-                                                            (lambda args
-                                                              (with-contract-continuation-mark
-                                                               (cons blame neg-party)
-                                                               (apply p-neg args)))
-                                                            neg-party)))))
+      (define (install-new-fields pos-field-projs neg-field-projs)
+        (for ([f (in-list fields)]
+              [c (in-list field-contracts)]
+              [p-pos (in-list pos-field-projs)]
+              [p-neg (in-list neg-field-projs)])
+          (unless (just-check-existence? c)
+            (define fi (hash-ref field-ht f))
+            (hash-set! field-ht f (field-info-extend-external
+                                   fi
+                                   (lambda args
+                                     (with-contract-continuation-mark
+                                         (cons blame neg-party)
+                                       (apply p-pos args)))
+                                   (lambda args
+                                     (with-contract-continuation-mark
+                                         (cons blame neg-party)
+                                       (apply p-neg args)))
+                                   neg-party)))))
+      (cond
+        [filled? (install-new-fields maybe-pos-field-projs maybe-neg-field-projs)]
+        [(thread-cell-ref tc)
+         =>
+         (λ (pr) (install-new-fields (car pr) (cdr pr)))]
+        [else
+         (define pos-field-projs (maybe-pos-field-projs))
+         (define neg-field-projs (maybe-neg-field-projs))
+         (thread-cell-set! tc (cons pos-field-projs neg-field-projs))
+         (install-new-fields pos-field-projs neg-field-projs)]))
     
     (copy-seals cls c))))