Avoid repeatedly constructing contracts as a result of checking a recursive contract

This may provide a speedup on Typed Racket programs that spend a lot of time
constructing contracts.

pkgs/racket-test/tests/racket/contract/recursive-contract.rkt

@@ -2,7 +2,8 @@
 (require "test-util.rkt")
 
 (parameterize ([current-contract-namespace
-                (make-basic-contract-namespace)])
+                (make-basic-contract-namespace
+                 'racket/contract)])
   
   (test/spec-passed
    'recursive-contract1
@@ -84,6 +85,34 @@
    '(letrec ([ctc (or/c number? (cons/c number? (recursive-contract ctc #:flat #:extra-delay)))])
       (contract ctc (cons 1 (cons 2 'not-a-number)) 'pos 'neg)))
 
+  (test/spec-passed/result
+   'memoize-applied-blame
+   '(let ()
+      (define counter 0)
+      (define my-ctc
+        (make-contract
+         #:first-order integer?
+         #:late-neg-projection
+         (lambda (blame)
+           (set! counter (add1 counter))
+           (lambda (val neg)
+             (if (integer? val)
+                 val
+                 (raise-blame-error
+                  blame
+                  val
+                  '(expected: "~a" given: "~e")
+                  "my-ctc" val))))))
+      (define ctc
+        (or/c my-ctc (vectorof (recursive-contract ctc))))
+      (define/contract v
+        ctc
+        (vector (vector (vector 5))))
+      (for ([i (in-range 100)])
+        (void (vector-ref v 0)))
+      counter)
+   2)
+
   (test/spec-passed/result
    'recursive-contract-not-too-slow
    '(let ()

racket/collects/racket/contract/private/base.rkt

@@ -222,8 +222,11 @@
        (define r-ctc (force-recursive-contract ctc))
        (define f (get/build-late-neg-projection r-ctc))
        (define blame-known (blame-add-context blame #f))
+       (define f-blame-known (make-thread-cell #f))
        (λ (val neg-party)
-         ((f blame-known) val neg-party)))]))
+         (unless (thread-cell-ref f-blame-known)
+           (thread-cell-set! f-blame-known (f blame-known)))
+         ((thread-cell-ref f-blame-known) val neg-party)))]))
 
 (define (flat-recursive-contract-late-neg-projection ctc)
   (cond