diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl
index a2e7544759..8dc1c68b0c 100644
--- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl
+++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl
@@ -1999,7 +1999,7 @@ The @racket[define-struct/contract] form only allows a subset of the
                     [name-for-blame (code:line)
                      (code:line #:name-for-blame blame-id)]
                     [name-for-blame (code:line)
-                     (code:line #:no-context)])]{
+                     (code:line #:context-limit limit-expr)])]{
   Defines @racket[id] to be @racket[orig-id], but with the contract
   @racket[contract-expr].
   
@@ -2023,10 +2023,8 @@ The @racket[define-struct/contract] form only allows a subset of the
   @racket[#:name-for-blame] is supplied, in which case the identifier
   following it is used as the name in the error messages.
 
- If @racket[#:no-context] is supplied, the error message do
- not include the context information that indicates which
- sub-portion of the contract where the violation was
- detected.
+  If @racket[#:context-limit] is supplied, it behaves the same as
+  it does when supplied to @racket[contract].
 
   @examples[#:eval (contract-eval) #:once
             (module server racket/base
@@ -2043,7 +2041,8 @@ The @racket[define-struct/contract] form only allows a subset of the
             (eval:error (clients-fault))
             (eval:error (servers-fault))]
 
-  @history[#:changed "6.7.0.4" @elem{Added the @racket[#:name-for-blame] argument.}]
+  @history[#:changed "6.7.0.4" @elem{Added the @racket[#:name-for-blame] argument.}
+           #:changed "6.90.0.29" @elem{Added the @racket[#:context-limit] argument.}]
 
 }
 
@@ -2051,7 +2050,7 @@ The @racket[define-struct/contract] form only allows a subset of the
                      positive-blame-expr negative-blame-expr)
            (contract contract-expr to-protect-expr
                      positive-blame-expr negative-blame-expr
-                     #:no-context)
+                     #:context-limit limit-expr)
            (contract contract-expr to-protect-expr
                      positive-blame-expr negative-blame-expr
                      value-name-expr source-location-expr)]]{
@@ -2087,9 +2086,13 @@ reported by contract violations.  The expression must produce a @racket[srcloc]
 structure, @tech{syntax object}, @racket[#f], or a list or vector in the format
 accepted by the third argument to @racket[datum->syntax].
 
-If @racket[#:no-context] is supplied, the error message do not include
-the context information that indicates which sub-portion of the contract
-where the violation was detected.
+ If @racket[#:context-limit] is supplied, the following expression
+ must evaluate to either @racket[#f] or a natural number. If
+ the expression evaluates to an natural number, the number of
+ layers of context information is limited to at most that
+ many. For example, if the number is @racket[0], no context
+ information is recorded and the error messages do not contain
+ the section that starts with @litchar{in:}.
 
 }
 
@@ -2532,6 +2535,12 @@ passing @racket[#f] as the context string argument avoids adding the
 @racket["..."] string.
 }
 
+@defproc[(blame-context [blame blame?]) (listof string?)]{
+  Returns the context information that would be supplied in
+  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]
diff --git a/pkgs/racket-test/tests/racket/contract/blame.rkt b/pkgs/racket-test/tests/racket/contract/blame.rkt
index 53e177be9d..c2a410dc46 100644
--- a/pkgs/racket-test/tests/racket/contract/blame.rkt
+++ b/pkgs/racket-test/tests/racket/contract/blame.rkt
@@ -126,6 +126,57 @@
        'neg2)
       'no-exn-raised)
    #t)
+  (test/spec-passed/result
+   'blame-selector.16
+   '(blame-context
+     (blame-add-context
+      (blame-add-context
+       (blame-add-context
+        (blame-add-context
+         (blame-add-context
+          (make-blame (srcloc "src.rkt" #f #f #f #f)
+                      'whatever (λ () 'the-name) 'pos #f #t)
+          "1")
+         "2")
+        "3")
+       "4")
+      "5"))
+   '("5" "4" "3" "2" "1"))
+  (test/spec-passed/result
+   'blame-selector.17
+   '(blame-context
+     (blame-add-context
+      (blame-add-context
+       (blame-add-context
+        (blame-add-context
+         (blame-add-context
+          (make-blame (srcloc "src.rkt" #f #f #f #f)
+                      'whatever (λ () 'the-name) 'pos 'neg #t
+                      #:context-limit 2)
+          "1")
+         "2")
+        "3")
+       "4")
+      "5"))
+   '("5" "4"))
+  (test/spec-passed/result
+   'blame-selector.18
+   '(blame-positive
+     (blame-add-context
+      (blame-add-context
+       (blame-add-context
+        (blame-add-context
+         (blame-add-context
+          (blame-swap
+           (make-blame (srcloc "src.rkt" #f #f #f #f)
+                       'whatever (λ () 'the-name) 'pos 'neg #t
+                       #:context-limit 2))
+          "1")
+         "2")
+        "3")
+       "4")
+      "5"))
+   'neg)
 
   (contract-eval
    #:test-case-name "blame.rkt setup.1"
@@ -392,12 +443,26 @@
    'blame-no-context
    ;; when the "in" has the contract after it, there is no context
    '(regexp-match? #rx"in: [(]list/c"
-                   (with-handlers ([exn:fail? exn-message])
+                   (with-handlers ([exn:fail:contract:blame? exn-message])
                      ((car (contract (list/c (-> integer? integer?))
                                      (list (λ (x) x))
                                      'pos
                                      'neg
-                                     #:no-context))
+                                     #:limit-context 0))
+                      #f)))
+   #t)
+
+  (test/spec-passed/result
+   'blame-1-context
+   ;; make sure that, when there is one frame of context,
+   ;; we do not see the `list/c` part of the context
+   '(regexp-match? #rx"element of"
+                   (with-handlers ([exn:fail:contract:blame? exn-message])
+                     ((car (contract (list/c (-> integer? integer?))
+                                     (list (λ (x) x))
+                                     'pos
+                                     'neg
+                                     #:limit-context 10))
                       #f)))
    #t)
 
diff --git a/pkgs/racket-test/tests/racket/contract/contract-out.rkt b/pkgs/racket-test/tests/racket/contract/contract-out.rkt
index 1d8246e01e..d1c2d82113 100644
--- a/pkgs/racket-test/tests/racket/contract/contract-out.rkt
+++ b/pkgs/racket-test/tests/racket/contract/contract-out.rkt
@@ -1599,7 +1599,7 @@
                  internal-name (list/c (-> integer? integer?))
                  #:pos-source 'pos
                  #:name-for-blame my-favorite-name
-                 #:no-context)
+                 #:context-limit 0)
                (provide external-name)))
       (eval '(module define-module-boundary-contract6-n racket/base
                (require 'define-module-boundary-contract6-m)
diff --git a/racket/collects/racket/contract/private/arrow-common.rkt b/racket/collects/racket/contract/private/arrow-common.rkt
index 341e687340..5cbc8518f7 100644
--- a/racket/collects/racket/contract/private/arrow-common.rkt
+++ b/racket/collects/racket/contract/private/arrow-common.rkt
@@ -349,8 +349,8 @@
                                #:missing-party [missing-party #f])
   (define num-values (length results))
   (define blame-case (if case-context 
-                         (blame-add-context blame (format "the ~a case of"
-                                                          (n->th (+ case-context 1))))
+                         (blame-add-context blame
+                                            (nth-case-of (+ case-context 1)))
                          blame))
   (raise-blame-error (blame-add-range-context blame-case)
                      #:missing-party missing-party
@@ -360,8 +360,7 @@
                      num-values (if (= num-values 1) "" "s")))
 
 (define (blame-add-nth-arg-context blame n)
-  (blame-add-context blame
-                     (format "the ~a argument of" (n->th n))))
+  (blame-add-context blame (nth-argument-of n)))
 
 (define (raise-wrong-number-of-args-error
          blame #:missing-party [missing-party #f] val
diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt
index 9d37c7a883..3e8b195d99 100644
--- a/racket/collects/racket/contract/private/arrow-higher-order.rkt
+++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt
@@ -560,7 +560,7 @@
                  [n (in-naturals 1)])
         ((get/build-late-neg-projection dom)
          (blame-add-context orig-blame 
-                            (format "the ~a argument of" (n->th (if method? (sub1 n) n)))
+                            (nth-argument-of (if method? (sub1 n) n))
                             #:swap? #t))))
     (define rest-blame
       (if (ellipsis-rest-arg-ctc? rest)
diff --git a/racket/collects/racket/contract/private/base.rkt b/racket/collects/racket/contract/private/base.rkt
index d169fdddfb..964dbb898e 100644
--- a/racket/collects/racket/contract/private/base.rkt
+++ b/racket/collects/racket/contract/private/base.rkt
@@ -39,24 +39,35 @@
          (quasisyntax/loc stx (#%expression #,stx)))))
 
 (define-syntax (contract stx)
+
+  (let ([l (syntax->list stx)])
+    (when l
+      (for ([thing (in-list (cdr (syntax->list stx)))])
+        (when (keyword? (syntax-e thing))
+          (unless (equal? (syntax-e thing) '#:limit-context)
+            (raise-syntax-error 'contract
+                                (format "did not expect keyword ~a" (syntax-e thing))
+                                stx
+                                thing))))))
+  
   (syntax-case stx ()
+    [(_ c v pos neg #:limit-context limit-context-expression)
+     (with-syntax ([name (syntax-local-infer-name stx)])
+       (syntax/loc stx
+         (apply-contract c v pos neg 'name
+                         (build-source-location #f)
+                         limit-context-expression)))]
     [(_ c v pos neg name loc)
      (syntax/loc stx
-       (apply-contract c v pos neg name loc #t))]
+       (apply-contract c v pos neg name loc #f))]
     [(_ c v pos neg)
      (with-syntax ([name (syntax-local-infer-name stx)])
-      (syntax/loc stx
-        (apply-contract c v pos neg 'name
-                        (build-source-location #f)
-                        #t)))]
-    [(_ c v pos neg #:no-context)
-     (with-syntax ([name (syntax-local-infer-name stx)])
-      (syntax/loc stx
-        (apply-contract c v pos neg 'name
-                        (build-source-location #f)
-                        #f)))]))
+       (syntax/loc stx
+         (apply-contract c v pos neg 'name
+                         (build-source-location #f)
+                         #f)))]))
 
-(define (apply-contract c v pos neg name loc track-context?)
+(define (apply-contract c v pos neg name loc context-limit)
   (let ([c (coerce-contract 'contract c)])
     (check-source-location! 'contract loc)
     (define clnp (contract-late-neg-projection c))
@@ -75,7 +86,7 @@
                   
                   (if clnp #f neg)
                   #t
-                  #:track-context? track-context?))
+                  #:context-limit context-limit))
     (cond
       [clnp (with-contract-continuation-mark
              (cons blame neg)
diff --git a/racket/collects/racket/contract/private/blame.rkt b/racket/collects/racket/contract/private/blame.rkt
index 7677af5f49..fdc340d448 100644
--- a/racket/collects/racket/contract/private/blame.rkt
+++ b/racket/collects/racket/contract/private/blame.rkt
@@ -31,48 +31,92 @@
 (define invariant-assertion-party (string->uninterned-symbol "invariant-assertion"))
 
 (define (blame=? a b equal?/recur)
-  (and (equal?/recur (blame-positive a) (blame-positive b))
-       (equal?/recur (blame-negative a) (blame-negative b))
-       (equal?/recur (blame-original? a) (blame-original? b))
-       (equal?/recur (blame-more-stuff a) (blame-more-stuff b))))
+  (and (or (and (blame-no-swap? a) (blame-no-swap? b))
+           (and (blame-yes-swap? a) (blame-yes-swap? b)))
+       (equal?/recur (blame-context-frame a) (blame-context-frame b))
+       (equal?/recur (blame-and-more a) (blame-and-more b))))
 
-(define (combine-them . args)
-  (let loop ([args args])
-    (cond
-      [(null? (cdr args)) (car args)]
-      [else (bitwise-xor (car args) (* 3 (loop (cdr args))))])))
+(define (combine-them x y)
+  (bitwise-xor x (* 3 y)))
 
 (define (blame-hash b hash/recur)
-  (combine-them (hash/recur (blame-positive b))
-                (hash/recur (blame-negative b))
-                (hash/recur (blame-original? b))
-                (hash/recur (blame-more-stuff b))))
+  (combine-them (hash/recur (blame-no-swap? b))
+                (combine-them (hash/recur (blame-context-frame b))
+                              (hash/recur (blame-and-more b)))))
 
 ;; missing-party? field is #t when the missing party
 ;; is still missing and it is #f when the missing party
 ;; has been filled in (or if it was filled in from the start)
-(define-struct more-stuff
-  [source value build-name context top-known? important missing-party? extra-fields]
+(define-struct all-the-info
+  [positive
+   negative
+   source value build-name top-known? important missing-party? context-limit extra-fields]
   #:transparent)
 
-(define-struct blame
-  (positive negative original? [swapped #:mutable] more-stuff)
+;; and-more : (or/c blame-no-swap? blame-swap? all-the-info?)
+;; context : string?
+(define-struct blame (context-frame and-more)
   #:property prop:equal+hash
   (list blame=? blame-hash blame-hash))
 
-(define (blame-source b) (more-stuff-source (blame-more-stuff b)))
-(define (blame-value b) (more-stuff-value (blame-more-stuff b)))
-(define (blame-context b) (more-stuff-context (blame-more-stuff b)))
-(define (blame-top-known? b) (more-stuff-top-known? (blame-more-stuff b)))
-(define (blame-important b) (more-stuff-important (blame-more-stuff b)))
-(define (blame-missing-party? b) (more-stuff-missing-party? (blame-more-stuff b)))
-(define (blame-contract b) ((more-stuff-build-name (blame-more-stuff b))))
-(define (blame-extra-fields b) (more-stuff-extra-fields (blame-more-stuff b)))
+(define-struct (blame-no-swap blame) ()
+  #:property prop:equal+hash
+  (list blame=? blame-hash blame-hash))
+(define-struct (blame-yes-swap blame) ()
+  #:property prop:equal+hash
+  (list blame=? blame-hash blame-hash))
+
+(define (blame->all-the-info b)
+  (let loop ([b b])
+    (cond
+      [(blame? b) (loop (blame-and-more b))]
+      [else b])))
+(define (blame-source b) (all-the-info-source (blame->all-the-info b)))
+(define (blame-value b) (all-the-info-value (blame->all-the-info b)))
+(define (blame-top-known? b) (all-the-info-top-known? (blame->all-the-info b)))
+(define (blame-important b) (all-the-info-important (blame->all-the-info b)))
+(define (blame-missing-party? b) (all-the-info-missing-party? (blame->all-the-info b)))
+(define (blame-contract b) ((all-the-info-build-name (blame->all-the-info b))))
+(define (blame-extra-fields b) (all-the-info-extra-fields (blame->all-the-info b)))
+(define (blame-context-limit b) (all-the-info-context-limit (blame->all-the-info b)))
+
+(define (blame-get-info b f)
+  (let loop ([b b]
+             [swapped? #f])
+    (cond
+      [(blame-yes-swap? b) (loop (blame-and-more b) (not swapped?))]
+      [(blame-no-swap? b) (loop (blame-and-more b) swapped?)]
+      [else (f b swapped?)])))
+(define (blame-original? b) (blame-get-info b (λ (all-the-info swapped?) (not swapped?))))
+(define (blame-swapped? b) (blame-get-info b (λ (all-the-info swapped?) swapped?)))
+(define (blame-positive b)
+  (blame-get-info b (λ (all-the-info swapped?)
+                      (if swapped?
+                          (all-the-info-negative all-the-info)
+                          (all-the-info-positive all-the-info)))))
+(define (blame-negative b)
+  (blame-get-info b (λ (all-the-info swapped?)
+                      (if swapped?
+                          (all-the-info-positive all-the-info)
+                          (all-the-info-negative all-the-info)))))
+
+(define (blame-context b)
+  (let loop ([top (blame-context-frame b)]
+             [b (blame-and-more b)])
+    (cond
+      [(all-the-info? b)
+       ;; there is a dummy #f at the end
+       ;; but it might be dropped if the
+       ;; context is limited, so we don't
+       ;; include it in the list
+       (if top (list top) '())]
+      [else (cons top (loop (blame-context-frame b)
+                            (blame-and-more b)))])))
 
 (define -make-blame
   (let ([make-blame
          (λ (source value build-name positive negative original?
-                    #:track-context? [track-context? #t])
+                    #:context-limit [context-limit #f])
            (unless (srcloc? source)
              (raise-argument-error 'make-blame "srcloc?" 0
                                    source value build-name positive negative original?))
@@ -83,6 +127,11 @@
            (unless positive
              (raise-type-error 'make-blame "(not/c #f)" 3
                                source value build-name positive negative original?))
+           (unless (or (not context-limit)
+                       (exact-nonnegative-integer? context-limit))
+             (raise-argument-error 'make-blame
+                                   (format "~s" '(or/c #f natural?))
+                                   context-limit))
            (define build/memo-name
              (let* ([uniq (box #f)]
                     [ans uniq])
@@ -90,46 +139,27 @@
                  (when (eq? uniq ans)
                    (set! ans (build-name)))
                  ans)))
-           (define more-stuff
-             (make-more-stuff
+           (define all-the-info
+             (make-all-the-info
+              (list positive)
+              (and negative (list negative))
               source
               value
               build/memo-name
-              (if track-context? '() #f)
               #t
               #f
               (not negative)
+              context-limit
               '()))
-           (new-blame (list positive)
-                      (and negative (list negative))
-                      original?
-                      more-stuff))])
+           ;; we always start with a yes-swap or no-swap struct
+           ;; so be careful in other parts of the code to ignore
+           ;; it, as appropriate.
+           (if original?
+               (blame-no-swap/intern #f all-the-info)
+               (blame-yes-swap/intern #f all-the-info)))])
     make-blame))
 
-(define (new-blame/more-stuff b more-stuff)
-  (new-blame (blame-positive b)
-             (blame-negative b)
-             (blame-original? b)
-             more-stuff))
-
-(define (new-blame poss negs original? more-stuff)
-  (define original-blame
-    (make-blame
-     poss
-     negs
-     original?
-     #f
-     more-stuff))
-  (define swapped-blame
-    (make-blame
-     negs
-     poss
-     (not original?)
-     original-blame
-     more-stuff))
-  (set-blame-swapped! original-blame swapped-blame)
-  original-blame)
-
+(define seen '())
 (define (blame-add-context b s #:important [name #f] #:swap? [swap? #f])
   (unless (blame? b)
     (raise-argument-error 'blame-add-context
@@ -147,55 +177,164 @@
 (define (blame-add-unknown-context b)
   (do-blame-add-context b #f #f #f))
 
+(define (make-blame-yes/no-swap/intern blame-yes/no-swap)
+  (define ht (make-hash))
+  (define (blame-yes/no-swap/intern s b)
+    (define b-table (hash-ref! ht s make-hash))
+    (hash-ref! b-table b (λ () (blame-yes/no-swap s b))))
+  blame-yes/no-swap/intern)
+
+(define blame-no-swap/intern (make-blame-yes/no-swap/intern blame-no-swap))
+(define blame-yes-swap/intern (make-blame-yes/no-swap/intern blame-yes-swap))
+
 (define (do-blame-add-context b s name swap?)
+  (define context-limit (blame-context-limit b))
   (cond
-    [(and (not (blame-context b))
+    [(and context-limit
           ;; if we are not tracking context,
           ;; we are not updating the name
           ;; at the top of the messages either
           ; (not name)
           (blame-top-known? b))
-     (if swap? (blame-swap b) b)]
+     (cond
+       [(and s (not (zero? context-limit)))
+        ;; if the limit is zero, we skip this case,
+        ;; which has the effect of always keeping only
+        ;; the dummy context frame
+        (define-values (limited-b dropped-swap?) (drop-to-limit b context-limit))
+        (if (equal? dropped-swap? swap?)
+            (blame-no-swap/intern s limited-b)
+            (blame-yes-swap/intern s limited-b))]
+       [swap?
+        (if (blame-yes-swap? b)
+            (blame-no-swap/intern (blame-context-frame b) (blame-and-more b))
+            (blame-yes-swap/intern (blame-context-frame b) (blame-and-more b)))]
+       [else b])]
     [else
-     (define new-original? (if swap? (not (blame-original? b)) (blame-original? b)))
-     (define new-context (if (and s (blame-context b))
-                             (cons s (blame-context b))
-                             (blame-context b)))
-     (define new-context/maybe-unknown
-       (if (or s (blame-top-known? b))
-           new-context
-           (cons "..." new-context)))
-     (define maybe-swapped (if swap? (blame-swap b) b))
-     (new-blame/more-stuff
-      maybe-swapped
-      (struct-copy
-       more-stuff (blame-more-stuff b)
-       [important (if name (important name new-original?) (blame-important b))]
-       [context new-context/maybe-unknown]
-       [top-known? (string? s)]))]))
+     (define blame-yes/no-swap (if swap? blame-yes-swap/intern blame-no-swap/intern))
+     (define inside-part
+       (let/ec k
+         (let loop ([inner-b b])
+           (cond
+             [(blame-yes-swap? inner-b)
+              (blame-yes-swap/intern (blame-context-frame inner-b) (loop (blame-and-more inner-b)))]
+             [(blame-no-swap? inner-b)
+              (blame-no-swap/intern (blame-context-frame inner-b) (loop (blame-and-more inner-b)))]
+             [else
+              (define top-known? (all-the-info-top-known? inner-b))
+              (cond
+                [(or (equal? top-known? (string? s))
+                     name)
+                 (define new-original? (if swap? (not (blame-original? b)) (blame-original? b)))
+                 ;; in this case, we need to make a new blame record
+                 (struct-copy
+                  all-the-info inner-b
+                  [important (if name
+                                 (important name new-original?)
+                                 (all-the-info-important inner-b))]
+                  [top-known? (string? s)])]
+                [else
+                 ;; we can skip all that pending work
+                 ;; of making a copy in this case
+                 (k b)])]))))
+     (if swap?
+         (blame-yes-swap/intern s inside-part)
+         (blame-no-swap/intern s inside-part))]))
 
+(define (drop-to-limit b context-limit)
+  (define short-enough?
+    (let loop ([b b]
+               [n (- context-limit 1)])
+      (cond
+        [(all-the-info? b) #t]
+        [(blame? b)
+         (if (zero? n)
+             #f
+             (loop (blame-and-more b) (- n 1)))])))
+  (cond
+    [short-enough? (values b #f)]
+    [else
+     (define swapped? #f)
+     (define limited-b
+       (let loop ([b b]
+                  [n (- context-limit 1)])
+         (cond
+           [(= n 0)
+            (let loop ([b b]
+                       [swap? #f])
+              (cond
+                [(blame-yes-swap? b) (loop (blame-and-more b) (not swap?))]
+                [(blame-no-swap? b) (loop (blame-and-more b) swap?)]
+                [else
+                 (set! swapped? swap?)
+                 b]))]
+           [(blame-no-swap? b)
+            (blame-no-swap/intern (blame-context-frame b)
+                                  (loop (blame-and-more b) (- n 1)))]
+           [(blame-yes-swap? b)
+            (blame-yes-swap/intern (blame-context-frame b)
+                                   (loop (blame-and-more b) (- n 1)))])))
+     (values limited-b swapped?)]))
+  
 (struct important (name sense-swapped?) #:transparent)
 
-(define (blame-swap b) (blame-swapped b))
+(define (blame-swap b)
+  (cond
+    [(blame-yes-swap? b)
+     (blame-no-swap/intern (blame-context-frame b) (blame-and-more b))]
+    [(blame-no-swap? b)
+     (blame-yes-swap/intern (blame-context-frame b) (blame-and-more b))]))
 
 (define (blame-replace-negative b new-neg)
-  (new-blame (blame-positive b)
-             (list new-neg)
-             (blame-original? b)
-             (blame-more-stuff b)))
+  (update-the-info
+   b
+   (λ (an-all-the-info swap?)
+     (if swap?
+         (all-the-info-replace-positive an-all-the-info new-neg)
+         (all-the-info-replace-negative an-all-the-info new-neg)))))
 
 (define (blame-replace-positive b new-pos)
-  (new-blame (list new-pos)
-             (blame-negative b)
-             (blame-original? b)
-             (blame-more-stuff b)))
+  (update-the-info
+   b
+   (λ (an-all-the-info swap?)
+     (if swap?
+         (all-the-info-replace-negative an-all-the-info new-pos)
+         (all-the-info-replace-positive an-all-the-info new-pos)))))
+
+(define (all-the-info-replace-positive an-all-the-info new-pos)
+  (struct-copy
+   all-the-info an-all-the-info
+   [positive (list new-pos)]))
+
+(define (all-the-info-replace-negative an-all-the-info new-neg)
+  (struct-copy
+   all-the-info an-all-the-info
+   [negative (list new-neg)]))
 
 (define (blame-update b extra-positive extra-negative)
   (ensure-blame-known 'blame-update b)
-  (new-blame (cons extra-positive (blame-positive b))
-             (cons extra-negative (blame-negative b))
-             (blame-original? b)
-             (blame-more-stuff b)))
+  (update-the-info
+   b
+   (λ (an-all-the-info swap?)
+     (if swap?
+         (struct-copy
+          all-the-info an-all-the-info
+          [positive (cons extra-negative (all-the-info-positive an-all-the-info))]
+          [negative (cons extra-positive (all-the-info-negative an-all-the-info))])
+         (struct-copy
+          all-the-info an-all-the-info
+          [positive (cons extra-positive (all-the-info-positive an-all-the-info))]
+          [negative (cons extra-negative (all-the-info-negative an-all-the-info))])))))
+
+(define (update-the-info b f)
+  (let loop ([b b]
+             [swap? #f])
+    (cond
+      [(blame-yes-swap? b)
+       (blame-yes-swap/intern (blame-context-frame b) (loop (blame-and-more b) (not swap?)))]
+      [(blame-no-swap? b)
+       (blame-no-swap/intern (blame-context-frame b) (loop (blame-and-more b) swap?))]
+      [else (f b swap?)])))
 
 (define (ensure-blame-known who blame)
   (unless (and (blame-positive blame)
@@ -212,9 +351,6 @@
 (define (show-blame-positive b) (show-blame blame-positive b))
 (define (show-blame-negative b) (show-blame blame-negative b))
 
-(define (blame-swapped? b)
-  (not (blame-original? b)))
-
 (define-struct (exn:fail:contract:blame exn:fail:contract) [object]
   #:transparent)
 
@@ -255,32 +391,21 @@
     blame)))
 
 (define (blame-add-missing-party b missing-party)
-
-  (define (check-and-fail)
-    (unless (blame-missing-party? b)
-      (error 'blame-add-missing-party "already have the party: ~s; trying to add ~s" 
-             (if (blame-swapped? b) (blame-positive b) (blame-negative b))
-             missing-party)))
   (cond
     [(not missing-party) b]
-    [(blame-swapped? b)
-     (check-and-fail)
-     (new-blame (or (blame-positive b)
-                    (list missing-party))
-                (blame-negative b)
-                (blame-original? b)
-                (struct-copy
-                 more-stuff (blame-more-stuff b)
-                 [missing-party? #f]))]
     [else
-     (check-and-fail)
-     (new-blame (blame-positive b)
-                (or (blame-negative b)
-                    (list missing-party))
-                (blame-original? b)
-                (struct-copy
-                 more-stuff (blame-more-stuff b)
-                 [missing-party? #f]))]))
+     (unless (blame-missing-party? b)
+       (error 'blame-add-missing-party "already have the party: ~s; trying to add ~s"
+              (if (blame-swapped? b) (blame-positive b) (blame-negative b))
+              missing-party))
+     (update-the-info
+      b
+      (λ (an-all-the-info swap?)
+        (struct-copy
+         all-the-info an-all-the-info
+         [negative (or (all-the-info-negative an-all-the-info)
+                       (list missing-party))]
+         [missing-party? #f])))]))
 
 (define (blame-fmt->-string blame fmt)
   (cond
@@ -454,13 +579,14 @@
     (raise-argument-error 'blame-add-extra-field
                           "string?"
                           2 b name field))
-  (new-blame/more-stuff
+  (update-the-info
    b
-   (struct-copy
-    more-stuff (blame-more-stuff b)
-    [extra-fields (cons (format "  ~a: ~a" name field)
-                        (blame-extra-fields b))])))
-  
+   (λ (an-all-the-info swap?)
+     (struct-copy
+      all-the-info an-all-the-info
+      [extra-fields (cons (format "  ~a: ~a" name field)
+                          (blame-extra-fields b))]))))
+
 ;; combine-lines : (-> (listof (or/c string? #f))) string?)
 ;; combines each of 'lines' into a single message, dropping #fs,
 ;; and otherwise guaranteeing that each string is on its own line,
@@ -505,10 +631,8 @@
     [(path? x) (path->relative-string/library x)]
     [else x]))
 
-
 (define (from-info x)
-  (convert-blame-singleton (last x))) 
-
+  (convert-blame-singleton (last x)))
 
 (define (convert-blame-party x)
   (let ((preface 
diff --git a/racket/collects/racket/contract/private/case-arrow.rkt b/racket/collects/racket/contract/private/case-arrow.rkt
index a3c181fd24..68ffbad969 100644
--- a/racket/collects/racket/contract/private/case-arrow.rkt
+++ b/racket/collects/racket/contract/private/case-arrow.rkt
@@ -217,8 +217,8 @@
                                          (blame-add-context 
                                           (blame-add-context 
                                            blame 
-                                           (format "the ~a case of" (n->th (+ (car f) 1)))) 
-                                          "the domain of" 
+                                           (nth-case-of (+ (car f) 1)))
+                                          "the domain of"
                                           #:swap? #t)))
                                  dom-ctcs+case-nums)
                             (map (let ([memo '()])
diff --git a/racket/collects/racket/contract/private/guts.rkt b/racket/collects/racket/contract/private/guts.rkt
index 295a5fd479..2f52515808 100644
--- a/racket/collects/racket/contract/private/guts.rkt
+++ b/racket/collects/racket/contract/private/guts.rkt
@@ -83,6 +83,9 @@
          raise-predicate-blame-error-failure
 
          n->th
+         nth-argument-of
+         nth-element-of
+         nth-case-of
 
          false/c-contract
          true/c-contract
@@ -918,6 +921,33 @@
      [(3) "rd"]
      [else "th"])))
 
+(define (nth-element-of/alloc n)
+  (format "the ~a element of" (n->th n)))
+(define (nth-argument-of/alloc n)
+  (format "the ~a argument of" (n->th n)))
+(define (nth-case-of/alloc n)
+  (format "the ~a case of" (n->th n)))
+
+(define-syntax (define-precompute/simple stx)
+  (syntax-case stx ()
+    [(_ fn fn/alloc lower-bound-stx upper-bound-stx)
+     (let ()
+       (define lower-bound (syntax-e #'lower-bound-stx))
+       (define upper-bound (syntax-e #'upper-bound-stx))
+       (define (n->id n)
+         (string->symbol (format "precomputed-~a" n)))
+     #`(begin
+         #,@(for/list ([i (in-range lower-bound (+ upper-bound 1))])
+              #`(define #,(n->id i) (fn/alloc #,i)))
+         (define (fn n)
+           (case n
+             #,@(for/list ([i (in-range lower-bound (+ upper-bound 1))])
+                  #`[(#,i) #,(n->id i)])
+             [else (fn/alloc n)]))))]))
+
+(define-precompute/simple nth-element-of nth-element-of/alloc 0 10)
+(define-precompute/simple nth-argument-of nth-argument-of/alloc 1 7)
+(define-precompute/simple nth-case-of nth-case-of/alloc 1 2)
 
 (define-syntax-rule
   (contract-pos/neg-doubling e1 e2)
diff --git a/racket/collects/racket/contract/private/list.rkt b/racket/collects/racket/contract/private/list.rkt
index 4cb7d12f81..7bafc0a7b3 100644
--- a/racket/collects/racket/contract/private/list.rkt
+++ b/racket/collects/racket/contract/private/list.rkt
@@ -811,13 +811,7 @@
          (expected-a-list val blame #:missing-party neg-party)]))))
 
 (define (add-list-context blame i)
-  (blame-add-context blame (format "the ~a~a element of"
-                                   i
-                                   (case (modulo i 10)
-                                     [(1) "st"]
-                                     [(2) "nd"]
-                                     [(3) "rd"]
-                                     [else "th"]))))
+  (blame-add-context blame (nth-element-of i)))
 
 (struct chaperone-list/c generic-list/c ()
   #:property prop:custom-write custom-write-property-proc
diff --git a/racket/collects/racket/contract/private/provide.rkt b/racket/collects/racket/contract/private/provide.rkt
index eb620d4f54..48b076b264 100644
--- a/racket/collects/racket/contract/private/provide.rkt
+++ b/racket/collects/racket/contract/private/provide.rkt
@@ -260,7 +260,7 @@
                                                                     (stx->srcloc-expr srcloc-id)
                                                                     'provide/contract
                                                                     pos-module-source
-                                                                    #t)
+                                                                    #f)
                              #,@(if provide?
                                     (list #`(provide (rename-out [#,id-rename external-name])))
                                     null)))
@@ -281,7 +281,7 @@
                                                         srcloc-expr
                                                         contract-error-name
                                                         pos-module-source
-                                                        track-context?)
+                                                        context-limit)
   (define-values (arrow? the-valid-app-shapes)
     (syntax-case ctrct (-> ->* ->i)
       [(-> . _) 
@@ -309,7 +309,7 @@
                            '#,name-for-blame
                            #,pos-module-source
                            #,srcloc-expr
-                           '#,track-context?))
+                           #,context-limit))
          #,@(if arrow?
                 (list #`(define extra-neg-party-argument-fn 
                           (wrapped-extra-arg-arrow-extra-neg-party-argument
@@ -354,17 +354,17 @@
             (raise-syntax-error #f "expected an identifier" stx #'new-id))
           (unless (identifier? #'orig-id)
             (raise-syntax-error #f "expected an identifier" stx #'orig-id))
-          (define-values (pos-blame-party-expr srcloc-expr name-for-blame track-context?)
+          (define-values (pos-blame-party-expr srcloc-expr name-for-blame context-limit)
             (let loop ([kwd-args (syntax->list #'(kwd-args ...))]
                        [pos-blame-party-expr #'(quote-module-path)]
                        [srcloc-expr #f]
                        [name-for-blame #f]
-                       [track-context? #t])
+                       [context-limit #f])
               (cond
                 [(null? kwd-args) (values pos-blame-party-expr
                                           (or srcloc-expr (stx->srcloc-expr stx))
                                           (or name-for-blame #'new-id)
-                                          track-context?)]
+                                          context-limit)]
                 [else
                  (define kwd (car kwd-args))
                  (cond 
@@ -376,7 +376,7 @@
                           (cadr kwd-args)
                           srcloc-expr
                           name-for-blame
-                          track-context?)]
+                          context-limit)]
                    [(equal? (syntax-e kwd) '#:srcloc)
                     (when (null? (cdr kwd-args))
                       (raise-syntax-error #f "expected a keyword argument to follow #:srcloc"
@@ -385,7 +385,7 @@
                           pos-blame-party-expr
                           (cadr kwd-args)
                           name-for-blame
-                          track-context?)]
+                          context-limit)]
                    [(equal? (syntax-e kwd) '#:name-for-blame)
                     (when (null? (cdr kwd-args))
                       (raise-syntax-error #f "expected a keyword argument to follow #:name-for-blame"
@@ -399,19 +399,22 @@
                           pos-blame-party-expr
                           srcloc-expr
                           name-for-blame
-                          track-context?)]
-                   [(equal? (syntax-e kwd) '#:no-context)
-                    (loop (cdr kwd-args)
+                          context-limit)]
+                   [(equal? (syntax-e kwd) '#:context-limit)
+                    (when (null? (cdr kwd-args))
+                      (raise-syntax-error #f "expected an expression to follow #:context-limit"
+                                          stx))
+                    (loop (cddr kwd-args)
                           pos-blame-party-expr
                           srcloc-expr
                           name-for-blame
-                          #f)]
+                          (cadr kwd-args))]
                    [else
                     (raise-syntax-error
                      #f
                      (string-append
                       "expected one of the keywords"
-                      " #:pos-source, #:srcloc, #:name-for-blame, or #:no-context")
+                      " #:pos-source, #:srcloc, #:name-for-blame, or #:context-limit")
                      stx
                      (car kwd-args))])])))
           (internal-function-to-be-figured-out #'ctrct
@@ -422,10 +425,10 @@
                                                srcloc-expr
                                                'define-module-boundary-contract
                                                pos-blame-party-expr
-                                               track-context?))])]))
+                                               context-limit))])]))
 
 ;; ... -> (values (or/c #f (-> neg-party val)) blame)
-(define (do-partial-app ctc val name pos-module-source source track-context?)
+(define (do-partial-app ctc val name pos-module-source source context-limit)
   (define p (parameterize ([warn-about-val-first? #f])
               ;; when we're building the val-first projection
               ;; here we might be needing the plus1 arity
@@ -437,7 +440,7 @@
                            (λ () (contract-name ctc))
                            pos-module-source
                            #f #t
-                           #:track-context? track-context?))
+                           #:context-limit context-limit))
   (with-contract-continuation-mark
    (cons blme 'no-negative-party) ; we don't know the negative party yet
    ;; computing neg-accepter may involve some front-loaded checking. instrument
diff --git a/racket/collects/racket/contract/private/vector.rkt b/racket/collects/racket/contract/private/vector.rkt
index 94d4ecf8c4..08f66c19ac 100644
--- a/racket/collects/racket/contract/private/vector.rkt
+++ b/racket/collects/racket/contract/private/vector.rkt
@@ -466,13 +466,12 @@
               ([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)))))
+               (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 (format "the ~a element of" (n->th i))
-                                  #:swap? #t)))))
+               (blame-add-context blame (nth-element-of i) #:swap? #t)))))
          (cond
            [filled?
             (λ (val neg-party)