Add contract-add-context to contract system.

This procedure is used to add blame contexts to an
existing contract. This prevents the need to re-create
the contract in order to add blame contexts.

collects/racket/contract/private/misc.rkt

@@ -45,7 +45,9 @@
          
          contract-projection
          contract-name
-         n->th)
+         n->th
+
+         contract-add-context)
 
 (define-syntax (flat-rec-contract stx)
   (syntax-case stx  ()
@@ -1013,3 +1015,69 @@
      [(3) "rd"]
      [else "th"])))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Adding blame context information to a contract
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; contract (or/c string #f) (or/c string #f) any -> contract
+;; Wrap the given contract, adding blame context information
+(define (contract-add-context contract context
+                              #:important [important #f]
+                              #:swap? [swap #f])
+  (define ctc (coerce-contract 'contract-add-context contract))
+  (unless (or (string? context) (not context))
+    (raise-type-error 'contract-add-context "string or #f" context))
+  (unless (or (string? important) (not important))
+    (raise-type-error 'contract-add-context "string or #f" important))
+  (cond [(flat-contract? ctc)
+         (flat-wrapper/c ctc context important swap)]
+        [(chaperone-contract? ctc)
+         (chaperone-wrapper/c ctc context important swap)]
+        [else
+         (impersonator-wrapper/c ctc context important swap)]))
+
+;; utilities for wrapping
+(define (wrapper/c-name ctc)
+  (contract-name (wrapper/c-ctc ctc)))
+
+(define ((wrapper/c-first-order ctc) v)
+  (contract-first-order-passes? (wrapper/c-ctc ctc) v))
+
+(define (wrapper/c-projection ctc)
+  (define proj (contract-projection (wrapper/c-ctc ctc)))
+  (λ (blame)
+    (define new-blame (construct-new-blame blame ctc))
+    (proj new-blame)))
+
+;; use blade-add-context to construct a new blame object
+(define (construct-new-blame blame ctc)
+  (define ctx (wrapper/c-context ctc))
+  (define imp? (wrapper/c-important ctc))
+  (define swap? (wrapper/c-swap? ctc))
+  (blame-add-context blame ctx #:important imp? #:swap? swap?))
+
+;; wrappers that track the extra context info to be added
+(struct wrapper/c (ctc context important swap?))
+
+(struct flat-wrapper/c wrapper/c ()
+        #:property prop:flat-contract
+        (build-flat-contract-property
+         #:name wrapper/c-name
+         #:first-order wrapper/c-first-order
+         #:projection wrapper/c-projection))
+
+(struct chaperone-wrapper/c wrapper/c ()
+        #:property prop:chaperone-contract
+        (build-chaperone-contract-property
+         #:name wrapper/c-name
+         #:first-order wrapper/c-first-order
+         #:projection wrapper/c-projection))
+
+(struct impersonator-wrapper/c wrapper/c ()
+        #:property prop:contract
+        (build-contract-property
+         #:name wrapper/c-name
+         #:first-order wrapper/c-first-order
+         #:projection wrapper/c-projection))

collects/scribblings/reference/contracts.scrbl

@@ -2059,6 +2059,18 @@ Produces the name used to describe the contract in error messages.
 Produces the projection defining a contract's behavior on protected values.
 }
 
+@defproc[(contract-add-context [contract contract?]
+                               [context (or/c string? #f)]
+                               [#:important important (or/c string? #f) #f]
+                               [#:swap? swap? any/c #f])
+         contract?]{
+  Produces a new contract that checks like @racket[contract], but
+  adds the context information @racket[context] to the resulting blame error
+  messages. The arguments are similar to those of @racket[blame-add-context].
+
+  See also @racket[blame-add-context].
+}
+
 @defproc[(make-none/c [sexp-name any/c]) contract?]{
 
 Makes a contract that accepts no values, and reports the

collects/tests/racket/contract-test.rktl

@@ -8391,6 +8391,52 @@
            [o (contract (instanceof/c (or/c c%/c d%/c)) (new c%) 'pos 'neg)])
       (send o m #t)))
 
+;; contract-add-context tests
+
+  (contract-error-test
+   'contract-add-context-1
+   #'((contract
+       (contract-add-context (-> integer? integer?)
+                             "additional info")
+       (λ (x) "bad")
+       'pos
+       'neg)
+      5)
+   (λ (x)
+     (and (exn:fail:contract:blame? x)
+          (regexp-match #rx"additional info" (exn-message x)))))
+
+  (contract-error-test
+   'contract-add-context-2
+   #'((contract
+       (contract-add-context (-> integer? integer?)
+                             "additional info"
+                             #:important "starts with")
+       (λ (x) "bad")
+       'pos
+       'neg)
+      5)
+   (λ (x)
+     (and (exn:fail:contract:blame? x)
+          (regexp-match #rx"additional info" (exn-message x))
+          (regexp-match #rx"^starts with:" (exn-message x))
+          (regexp-match #rx"blaming: pos" (exn-message x)))))
+
+  (contract-error-test
+   'contract-add-context-3
+   #'((contract
+       (contract-add-context (-> integer? integer?)
+                             "additional info"
+                             #:swap? #t)
+       (λ (x) "bad")
+       'pos
+       'neg)
+      5)
+   (λ (x)
+     (and (exn:fail:contract:blame? x)
+          (regexp-match #rx"additional info" (exn-message x))
+          (regexp-match #rx"blaming: neg" (exn-message x)))))
+
 ;                                                                                    
 ;                                                                                    
 ;