adjusted the contract error messages so that the words expected/promised

are switched in and out based on the sense of the blame (similar to a recent
change that made given/produced swap in and out)

collects/racket/contract/private/arrow.rkt

@@ -113,7 +113,7 @@ v4 todo:
                           [res-checker (λ (res-x ...) (values (p-app-x res-x) ...))])
                      (λ (val)
                        (unless (procedure? val)
-                         (raise-blame-error orig-blame val "expected a procedure, ~a ~v" (given/produced orig-blame) val))
+                         (raise-blame-error orig-blame val '(expected: "a procedure," given: "~v") val))
                        (wrapper
                         val
                         (make-keyword-procedure
@@ -389,12 +389,12 @@ v4 todo:
        (if (and (null? req-kwd) (null? opt-kwd))
            (λ (kwds kwd-args . args)
              (raise-blame-error (blame-swap blame) val
-                                "expected no keywords"))
+                                '(expected: "no keywords")))
            (λ (kwds kwd-args . args)
              (define args-len (length args))
              (unless (valid-number-of-args? args)
                (raise-blame-error (blame-swap blame) val
-                                  "received ~a argument~a, expected ~a"
+                                  '("received ~a argument~a," expected: "~a")
                                   args-len (if (= args-len 1) "" "s") arity-string))
              
              ;; these two for loops are doing O(n^2) work that could be linear 
@@ -402,7 +402,7 @@ v4 todo:
              (for ([req-kwd (in-list req-kwd)])
                (unless (memq req-kwd kwds)
                  (raise-blame-error (blame-swap blame) val
-                                    "expected keyword argument ~a"
+                                    '(expected "keyword argument ~a")
                                     req-kwd)))
              (for ([k (in-list kwds)])
                (unless (memq k all-kwds)
@@ -416,7 +416,7 @@ v4 todo:
              (unless (valid-number-of-args? args)
                (define args-len (length args))
                (raise-blame-error (blame-swap blame) val
-                                  "received ~a argument~a, expected ~a"
+                                  '("received ~a argument~a," expected: "~a")
                                   args-len (if (= args-len 1) "" "s") arity-string))
              (apply basic-lambda args))
            (λ args
@@ -1873,7 +1873,7 @@ v4 todo:
        (raise-blame-error
         blame
         val
-        "expected a ~a that accepts ~a~a~a argument~a~a~a, ~a: ~e"
+        '(expected" a ~a that accepts ~a~a~a argument~a~a~a," given: "~e")
         (if mtd? "method" "procedure")
         (if (zero? dom-length) "no" dom-length)
         (if (null? optionals) "" " mandatory")
@@ -1882,7 +1882,6 @@ v4 todo:
         (if (zero? optionals) ""
             (format " and up to ~a optional argument~a" optionals (if (= 1 optionals) "" "s")))
         (keyword-error-text mandatory-kwds optional-keywords)
-        (given/produced blame)
         val))]
     [else
      passes?]))
@@ -1949,14 +1948,13 @@ v4 todo:
        (raise-blame-error
         blame
         val
-        "expected a ~a that accepts ~a argument~a and arbitrarily more~a, ~a: ~e"
+        '(expected "a ~a that accepts ~a argument~a and arbitrarily more~a," given: "~e")
         (if mtd? "method" "procedure")
         (cond
           [(zero? dom-length) "no"]
           [else dom-length])
         (if (= 1 dom-length) "" "s")
         (keyword-error-text mandatory-kwds optional-kwds)
-        (given/produced blame)
         val))]
     [else
      passes?]))

collects/racket/contract/private/basic-opters.rkt

@@ -32,7 +32,7 @@
   (raise-blame-error
    blame
    val
-   "expected ~a"
+   '(expected: "~a")
    pred-name))
 
 ;;
@@ -93,9 +93,8 @@
                             (raise-blame-error
                              blame
                              val
-                             "expected: ~s, ~a: ~e"
+                             '(expected: "~s," given: "~e")
                              (contract-name ctc)
-                             (given/produced blame)
                              val)))
           #:lifts
           (interleave-lifts

collects/racket/contract/private/blame.rkt

@@ -15,11 +15,11 @@
          blame-add-context
          blame-add-unknown-context
          blame-context 
-         given/produced
          
          raise-blame-error
          current-blame-format
-         (struct-out exn:fail:contract:blame))
+         (struct-out exn:fail:contract:blame)
+         blame-fmt->-string)
 
 (define (blame=? a b equal?/recur)
   (and (equal?/recur (blame-source a) (blame-source b))
@@ -86,12 +86,61 @@
 (define-struct (exn:fail:contract:blame exn:fail:contract) [object]
   #:transparent)
 
-(define (raise-blame-error b x fmt . args)
+(define (raise-blame-error blame x fmt . args)
   (raise
    (make-exn:fail:contract:blame
-    ((current-blame-format) b x (apply format fmt args))
+    ((current-blame-format) 
+     blame x 
+     (apply format (blame-fmt->-string blame fmt) args))
     (current-continuation-marks)
-    b)))
+    blame)))
+
+(define (blame-fmt->-string blame fmt)
+  (cond
+    [(string? fmt) fmt]
+    [else
+     (let loop ([strs fmt]
+                [so-far '()]
+                [last-ended-in-whitespace? #t])
+       (cond
+         [(null? strs)
+          (apply string-append (reverse so-far))]
+         [else
+          (define fst (car strs))
+          (define nxt
+            (cond
+              [(eq? 'given: fst) (if (blame-original? blame)
+                                     "produced:"
+                                     "given:")]
+              [(eq? 'given fst) (if (blame-original? blame)
+                                    "produced"
+                                    "given")]
+              [(eq? 'expected: fst) (if (blame-original? blame)
+                                        "promised:"
+                                        "expected:")]
+              [(eq? 'expected fst) (if (blame-original? blame)
+                                       "promised"
+                                       "expected")]
+              [else fst]))
+          (define new-so-far
+            (if (or last-ended-in-whitespace?
+                    (regexp-match #rx"^ " nxt))
+                (cons nxt so-far)
+                (list* nxt " " so-far)))
+          (loop (cdr strs)
+                new-so-far
+                (regexp-match #rx" $" nxt))]))]))
+                
+
+(define (given/produced blame)
+  (if (blame-original? blame)
+      "produced"
+      "given"))
+
+(define (expected/promised blame)
+  (if (blame-original? blame)
+      "expected"
+      "promised"))
               
 (define (default-blame-format blme x custom-message)
   (define source-message (source-location->string (blame-source blme)))
@@ -113,7 +162,7 @@
                       (format "  at: ~a" source-message)))
   
   (define self-or-not (if (blame-original? blme)
-                          "self-contract violation"
+                          "broke it's contract"
                           "contract violation"))
   
   (define start-of-message
@@ -202,8 +251,3 @@
 (define current-blame-format
   (make-parameter default-blame-format))
 
-
-(define (given/produced blame)
-  (if (blame-original? blame)
-      "produced"
-      "given"))

collects/racket/contract/private/box.rkt

@@ -18,14 +18,14 @@
   (define elem-ctc (base-box/c-content ctc))
   (define immutable (base-box/c-immutable ctc))
   (unless (box? val)
-    (raise-blame-error blame val "expected a box, ~a: ~a" (given/produced blame) val))
+    (raise-blame-error blame val '(expected "a box," given: "~e") val))
   (case immutable
     [(#t)
      (unless (immutable? val)
-       (raise-blame-error blame val "expected an immutable box, ~a: ~a" (given/produced blame) val))]
+       (raise-blame-error blame val '(expected "an immutable box," given: "~e") val))]
     [(#f)
      (when (immutable? val)
-       (raise-blame-error blame val "expected a mutable box, ~a: ~a" (given/produced blame) val))]
+       (raise-blame-error blame val '(expected "a mutable box," given: "~e") val))]
     [(dont-care) (void)]))
 
 (define (box/c-first-order ctc)

collects/racket/contract/private/ds.rkt

@@ -253,7 +253,7 @@ it around flattened out.
                     (raise-blame-error
                      blame
                      val
-                     "expected: ~s, ~a ~e" 'name (given/produced blame) val))
+                     '(expected: "~s," given: "~e") 'name val))
                   (cond
                     [(already-there? contract/info val lazy-depth-to-look)
                      val]
@@ -459,9 +459,8 @@ it around flattened out.
                                 (raise-blame-error
                                  blame
                                  val
-                                 "expected: ~s, ~a ~e"
+                                 '(expected: "~s," given: "~e")
                                  (contract-name ctc)
-                                 (given/produced blame)
                                  val)]))
                             #:lifts lifts
                             #:superlifts superlifts
@@ -536,7 +535,8 @@ it around flattened out.
     (raise-blame-error
      (contract/info-blame contract/info)
      stct
-     "failed `and' clause, ~a ~e" (given/produced (contract/info-blame contract/info)) stct)))
+     '("failed `and' clause," given: "~e")
+     stct)))
 
 (define-values (evaluate-attr-prop evaluate-attr-prop-predicate evaluate-attr-prop-accessor)
   (make-struct-type-property 'evaluate-attr-prop))

collects/racket/contract/private/hash.rkt

@@ -82,23 +82,22 @@
   (define immutable (base-hash/c-immutable ctc))
   (define flat? (flat-hash/c? ctc))
   (unless (hash? val)
-    (raise-blame-error blame val "expected a hash, ~a: ~e" (given/produced blame) val))
+    (raise-blame-error blame val '(expected "a hash," given: "~e") val))
   (when (and (not flat?)
              (not (flat-contract? dom-ctc))
              (not (hash-equal? val)))
     (raise-blame-error blame val 
-                       "expected equal?-based hash table due to higher-order domain contract, ~a: ~e"
+                       '(expected "equal?-based hash table due to higher-order domain contract," given: "~e")
-                       (given/produced blame)
                        val))
   (case immutable
     [(#t) 
      (unless (immutable? val) 
        (raise-blame-error blame val
-                          "expected an immutable hash, ~a: ~e" (given/produced blame) val))]
+                          '(expected "an immutable hash," given: "~e") val))]
     [(#f)
      (when (immutable? val)
        (raise-blame-error blame val
-                          "expected an mutable hash, ~a: ~e" (given/produced blame) val))]
+                          '(expected "a mutable hash," given: "~e") val))]
     [(dont-care) (void)]))
 
 (define (hash/c-first-order ctc)

collects/racket/contract/private/misc.rkt

@@ -220,16 +220,14 @@
                 (if candidate-proc
                     (candidate-proc val)
                     (raise-blame-error blame val 
-                                       "none of the branches of the or/c matched, ~a: ~e"
+                                       '("none of the branches of the or/c matched," given: "~e")
-                                       (given/produced blame)
                                        val))]
                [((car checks) val)
                 (if candidate-proc
                     (raise-blame-error blame val
-                                       "two of the clauses in the or/c might both match: ~s and ~s, ~a: ~e"
+                                       '("two of the clauses in the or/c might both match: ~s and ~s," given: "~e")
                                        (contract-name candidate-contract)
                                        (contract-name (car contracts))
-                                       (given/produced blame)
                                        val)
                     (loop (cdr checks)
                           (cdr procs)
@@ -364,9 +362,8 @@
                (raise-blame-error
                 blame
                 val
-                  "expected: ~s, ~a: ~e, which isn't ~s"
+                '(expected: "~s," given: "~e, which isn't ~s")
                 (contract-name ctc)
-                  (given/produced blame)
                 val
                 (contract-name (car ctcs))))])))))
 
@@ -645,9 +642,8 @@
               (λ (val)
                 (unless (predicate? val)
                   (raise-blame-error blame val
-                                     "expected: ~s, ~a: ~e"
+                                     '(expected: "~s," given "~e")
                                      'type-name 
-                                     (given/produced blame)
                                      val))
                 (check-all p-app val))))
           (cond
@@ -692,8 +688,8 @@
               [cdr-p (cdr-proj (blame-add-context blame "the cdr of"))])
           (λ (v)
             (unless (pair? v)
-              (raise-blame-error blame v "expected <cons?>, ~a: ~e" 
+              (raise-blame-error blame v 
-                                 (given/produced blame)
+                                 '(expected "<pair?>," given: "~e")
                                  v))
             (combine v (car-p (car v)) (cdr-p (cdr v))))))
       (cond
@@ -747,17 +743,18 @@
      (lambda (blame)
        (lambda (x)
          (unless (list? x)
-           (raise-blame-error blame x "expected a list, ~a: ~e" (given/produced blame) x))
+           (raise-blame-error blame x '(expected "a list," given: "~e") x))
          (let* ([args (generic-list/c-args c)]
                 [expected (length args)]
                 [actual (length x)])
            (unless (= actual expected)
              (raise-blame-error
               blame x
-              "expected a list of ~a elements, but ~a ~a elements in: ~e"
+              '(expected "a list of ~a elements, but" given "~a element~a in: ~e")
               expected 
-              (given/produced blame)
+              actual
-              actual x))
+              (if (= actual 1) "" "s")
+              x))
            (for ([arg/c (in-list args)] [v (in-list x)] [i (in-naturals 1)])
              (((contract-projection arg/c) 
                (add-list-context blame i))
@@ -773,15 +770,16 @@
                     (arg/c (add-list-context blame i))))
     (λ (x)
       (unless (list? x)
-        (raise-blame-error blame x "expected a list, ~a: ~e" (given/produced blame) x))
+        (raise-blame-error blame x '(expected "a list," given: "~e") x))
       (define actual (length x))
       (unless (= actual expected)
         (raise-blame-error
          blame x
-         "expected a list of ~a elements, but ~a ~a elements in: ~e"
+         '(expected "a list of ~a elements, but" given "~a element~a in: ~e")
          expected
-         (given/produced blame)
+         actual
-         actual x))
+         (if (= actual 1) "" "s")
+         x))
       (for/list ([item (in-list x)]
                  [proj (in-list projs)])
         (proj item)))))
@@ -833,8 +831,7 @@
                (raise-blame-error
                 blame
                 val
-                "expected <promise>, ~a: ~e"
+                '(expected "<promise>," given: "~e")
-                (given/produced blame)
                 val))
              (delay (p-app (force val))))))
        #:first-order promise?))))
@@ -861,7 +858,7 @@
                 partial-neg-contract
                 partial-pos-contract)]
               [else
-               (raise-blame-error blame val "expected a parameter")])))))
+               (raise-blame-error blame val '(expected "a parameter"))])))))
 
    #:name
    (λ (ctc) (build-compound-type-name 'parameter/c (parameter/c-ctc ctc)))
@@ -911,7 +908,7 @@
       (raise-blame-error
        blame
        val
-       "~s accepts no values, given: ~e"
+       '("~s accepts no values," given: "~e")
        (none/c-name ctc)
        val))))
 

collects/racket/contract/private/opt.rkt

@@ -97,7 +97,7 @@
    #:chaperone #t))
 
 (define (opt-constant-contract-failure blame val compare should-be)
-  (raise-blame-error blame val "expected a value ~a to ~e" compare should-be))
+  (raise-blame-error blame val '(expected "a value ~a to ~e") compare should-be))
 
 (begin-for-syntax
   (define-struct define-opt/recursive-fn (transformer internal-fn neg-blame?-id)

collects/racket/contract/private/opters.rkt

@@ -183,10 +183,8 @@
   (raise-blame-error
    blame
    val
-   "expected a number between ~a and ~a, ~a: ~e"
+   '(expected "a number between ~a and ~a," given: "~e")
-   lo hi
+   lo hi val))
-   (given/produced blame)
-   val))
 
 (define-for-syntax (single-comparison-opter opt/info stx check-arg comparison arg)
   (with-syntax ([comparison comparison])
@@ -222,10 +220,8 @@
   (raise-blame-error
    blame
    val
-   "expected a number ~a ~a, ~a: ~e"
+   '(expected "a number ~a ~a," given: "~e")
-   (object-name comparison) m
+   (object-name comparison) m val))
-   (given/produced blame)
-   val))
 
 
 (define/opter (=/c opt/i opt/info stx)
@@ -308,9 +304,8 @@
                      (raise-blame-error
                       blame
                       val
-                      "expected: ~s, ~a: ~e"
+                      '(expected: "~s," given: "~e")
                       (contract-name ctc)
-                      (given/produced blame)
                       val))))
        #:lifts
        (append (optres-lifts optres-hd) (optres-lifts optres-tl))
@@ -358,8 +353,8 @@
                 blame
                 val
                 #,(if non-empty?
-                      "expected a non-empty list"
+                      #''(expected "a non-empty list")
-                      "expected a list")))))
+                      #''(expected "a list"))))))
      #:lifts (optres-lifts optres-ele)
      #:superlifts (optres-superlifts optres-ele)
      #:partials (optres-partials optres-ele)
@@ -589,13 +584,12 @@
 
 (define (raise-flat-arrow-err blame val n)
   (raise-blame-error blame val
-                     "expected a procedure matching the contract ~s"
+                     '(expected "a procedure matching the contract ~s")
                      `(-> ,@(build-list n (λ (x) 'any/c)) any)))
 
 (define (bad-number-of-arguments blame val args dom-len)
   (define num-values (length args))
   (raise-blame-error (blame-swap blame) val 
-                     "expected ~a argument~a, ~a ~a argument~a"
+                     '(expected "~a argument~a," given "~a argument~a")
                      dom-len (if (= dom-len 1) "" "s")
-                     (given/produced blame)
                      num-values (if (= num-values 1) "" "s")))

collects/racket/contract/private/parametric.rkt

@@ -46,7 +46,7 @@
 
        (lambda (p)
          (unless (procedure? p)
-           (raise-blame-error blame p "expected a procedure; ~a: ~e" (given/produced blame) p))
+           (raise-blame-error blame p '(expected "a procedure;" given: "~e") p))
          (make-keyword-procedure
           (lambda (keys vals . args) (keyword-apply (wrap p) keys vals args))
           (case-lambda
@@ -80,7 +80,6 @@
          (lambda (x)
            (if ((barrier-contract-pred c) x)
              ((barrier-contract-get c) x)
-             (raise-blame-error blame x "expected a(n) ~a; ~a: ~e"
+             (raise-blame-error blame x '(expected "a(n) ~a;" given: "~e")
                                 (barrier-contract-name c)
-                                (given/produced blame)
                                 x))))))))

collects/racket/contract/private/prop.rkt

@@ -262,9 +262,8 @@
         (if (first-order x)
             x
             (raise-blame-error b x
-                               "expected: ~s, ~a: ~e" 
+                               '(expected: "~s," given: "~e")
                                name 
-                               (given/produced b)
                                x))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

collects/racket/contract/private/struct-dc.rkt

@@ -189,7 +189,7 @@
          v]
         [else
          (unless (pred? v)
-           (raise-blame-error blame v "expected a ~a"
+           (raise-blame-error blame v '(expected: "~a")
                               (base-struct/dc-struct-name ctc)))
          (let loop ([subcontracts (base-struct/dc-subcontracts ctc)]
                     [projs projs]
@@ -955,7 +955,7 @@
 
 (define (struct/dc-error blame obj what)
   (raise-blame-error blame obj 
-                     "expected a struct of type ~a"
+                     '(expected "a struct of type ~a")
                      what))
 
 (define-syntax (struct/c stx)

collects/racket/contract/private/struct-prop.rkt

@@ -14,8 +14,7 @@
         (lambda (x)
           (unless (struct-type-property? x)
             (raise-blame-error blame x
-                               "expected struct-type-property, ~a: ~e"
+                               '(expected "struct-type-property," given: "~e")
-                               (given/produced blame)
                                x))
           (let-values ([(nprop _pred _acc)
                         (make-struct-type-property

collects/racket/contract/private/vector.rkt

@@ -49,20 +49,20 @@
         [flat? (flat-vectorof? c)])
     (λ (val fail first-order?)
       (unless (vector? val)
-        (fail val "expected a vector, got ~a" val))
+        (fail val '(expected "a vector," given: "~e") val))
       (cond
         [(eq? immutable #t)
          (unless (immutable? val)
-           (fail val "expected an immutable vector, got ~a" val))]
+           (fail val '(expected "an immutable vector," given: "~e") val))]
         [(eq? immutable #f)
          (when (immutable? val)
-           (fail val "expected an mutable vector, got ~a" val))]
+           (fail val '(expected "an mutable vector," given: "~e" val)))]
         [else (void)])
       (when first-order?
         (for ([e (in-vector val)]
               [n (in-naturals)])
           (unless (contract-first-order-passes? elem-ctc e)
-            (fail val "expected: ~s for element ~v, got ~v" (contract-name elem-ctc) n e))))
+            (fail val '(expected: "~s for element ~s," given "~e") (contract-name elem-ctc) n e))))
       #t)))
 
 (define (vectorof-first-order ctc)
@@ -182,29 +182,24 @@
   (define elem-ctcs (base-vector/c-elems ctc))
   (define immutable (base-vector/c-immutable ctc))
   (unless (vector? val)
-    (raise-blame-error blame val "expected a vector, ~a: ~e" 
+    (raise-blame-error blame val '(expected "a vector," given: "~e") val))
-                       (given/produced blame)
-                       val))
   (cond
     [(eq? immutable #t)
      (unless (immutable? val)
        (raise-blame-error blame val 
-                          "expected an immutable vector, ~a: ~e"
+                          '(expected "an immutable vector," given: "~e")
-                          (given/produced blame)
                           val))]
     [(eq? immutable #f)
      (when (immutable? val)
        (raise-blame-error blame val 
-                          "expected an mutable vector, ~a: ~e" 
+                          '(expected "a mutable vector," given: "~e")
-                          (given/produced blame)
                           val))]
     [else (void)])
   (define elem-count (length elem-ctcs))
   (unless (= (vector-length val) elem-count)
-    (raise-blame-error blame val "expected a vector of ~a element~a, ~a: ~e"
+    (raise-blame-error blame val '(expected "a vector of ~a element~a," given: "~e")
                        elem-count
                        (if (= elem-count 1) "" "s") 
-                       (given/produced blame)
                        val)))
 
 (define (vector/c-first-order ctc)

collects/scribblings/reference/contracts.scrbl

@@ -1273,7 +1273,7 @@ use in the contract system:
         (raise-blame-error
          blame
          val
-         "expected <integer>, given: ~e"
+         '(expected "<integer>," given: "~e")
          val))))
 ]
 The new argument specifies who is to be blamed for
@@ -1304,7 +1304,7 @@ Compare that to the projection for our function contract:
           (raise-blame-error
            blame
            val
-           "expected a procedure of one argument, given: ~e"
+           '(expected "a procedure of one argument," given: "~e")
            val)))))
 ]
 
@@ -1362,7 +1362,7 @@ when a contract violation is detected.
             (raise-blame-error
              blame
              val
-             "expected a procedure of one argument, given: ~e"
+             '(expected "a procedure of one argument," given: "~e")
              val))))))
 ]
 
@@ -1380,7 +1380,9 @@ the contract library primitives below.
                (if (test x)
                  x
                  (raise-blame-error
-                  b x "expected <~a>, given: ~e" name x))))]
+                  b x
+                  '(expected "<~a>," given: "~e")
+                  name x))))]
           [#:stronger stronger (-> contract? contract? boolean?)])
          contract?]
 @defproc[(make-chaperone-contract
@@ -1392,7 +1394,9 @@ the contract library primitives below.
                (if (test x)
                  x
                  (raise-blame-error
-                  b x "expected <~a>, given: ~e" name x))))]
+                  b x
+                  '(expected "<~a>," given: "~e")
+                  name x))))]
           [#:stronger stronger (-> contract? contract? boolean?)])
          chaperone-contract?]
 @defproc[(make-flat-contract
@@ -1404,7 +1408,9 @@ the contract library primitives below.
                (if (test x)
                  x
                  (raise-blame-error
-                  b x "expected <~a>, given: ~e" name x))))]
+                  b x
+                  '(expected "<~a>," given: "~e")
+                  name x))))]
           [#:stronger stronger (-> contract? contract? boolean?)])
          flat-contract?]
 )]{
@@ -1468,7 +1474,7 @@ was passed as the second argument to @racket[contract-stronger?].
            (λ (x) (range (f (domain x))))
            (raise-blame-error
             b f
-            "expected a function of one argument, got: ~e"
+            '(expected "a function of one argument," 'given: "~e")
             f)))))))
 (contract int->int/c "not fun" 'positive 'negative)
 (define halve 
@@ -1630,17 +1636,32 @@ the other; both are provided for convenience and clarity.
              position @racket[b] has.
 }
   
-@defproc[(raise-blame-error [b blame?] [x any/c] [fmt string?] [v any/c] ...)
+@defproc[(raise-blame-error [b blame?] 
+                            [x any/c] 
+                            [fmt (or/c string?
+                                       (listof (or/c string?
+                                                     'given 'given:
+                                                     'expected 'expected:)))]
+                            [v any/c] ...)
          none/c]{
 
 Signals a contract violation.  The first argument, @racket[b], records the
 current blame information, including positive and negative parties, the name of
 the contract, the name of the value, and the source location of the contract
 application.  The second argument, @racket[x], is the value that failed to
-satisfy the contract.  The remaining arguments are a format string,
+satisfy the contract.  
+
+The remaining arguments are a format string,
 @racket[fmt], and its arguments, @racket[v ...], specifying an error message
 specific to the precise violation.
 
+If @racket[fmt] is a list, then the elements are concatenated together 
+(with spaces added, unless there are already spaces at the ends of the strings),
+after first replacing symbols with either their string counterparts, or
+replacing @racket['given] with @racket["produced"] and 
+@racket['expected] with @racket["promised"], depending on whether or not
+the @racket[b] argument has been swapped or not (see @racket[blame-swap]).
+
 }
 
 @defstruct[(exn:fail:contract:blame exn:fail:contract) ([object blame?])]{

collects/tests/racket/contract-test.rktl

@@ -13,6 +13,7 @@
         (namespace-require 'scheme/contract)
         (namespace-require 'scheme/set)
         (namespace-require '(only racket/contract/private/arrow procedure-accepts-and-more?))
+        (namespace-require '(only racket/contract/private/blame blame-fmt->-string make-blame))
         (namespace-require 'scheme/class)
         (namespace-require 'scheme/promise)
         (namespace-require 'scheme/match))
@@ -143,7 +144,7 @@
       (define (has-proper-blame? msg)
         (define reg
           (cond
-            [(eq? blame 'pos) #rx"self-contract violation[\n:,].*blaming: pos"]
+            [(eq? blame 'pos) #rx"broke it's contract[\n:,].*blaming: pos"]
             [(eq? blame 'neg) #rx"blaming: neg"]
             [(string? blame) (string-append "blaming: " (regexp-quote blame))]
             [else #f]))
@@ -12741,6 +12742,12 @@ so that propagation occurs.
                  0)
                 1)))
   
+  (let* ([blame-pos (contract-eval '(make-blame #'here #f (λ () 'integer?) 'positive 'negative #t))]
+         [blame-neg (contract-eval `(blame-swap ,blame-pos))])
+    (ctest "something ~a" blame-fmt->-string ,blame-neg "something ~a")
+    (ctest "promised: ~s; produced: ~e" blame-fmt->-string ,blame-pos '(expected: "~s;" given: "~e"))
+    (ctest "expected: ~s; given: ~e" blame-fmt->-string ,blame-neg '(expected: "~s;" given: "~e")))
+  
 ;                                                        
 ;                                                        
 ;                                                        
@@ -13581,7 +13588,7 @@ so that propagation occurs.
        (eval '(require 'pce1-bug)))
    (λ (x)
      (and (exn:fail:contract:blame? x)
-          (regexp-match #rx"the-defined-variable1: self-contract violation" (exn-message x)))))
+          (regexp-match #rx"the-defined-variable1: broke it's contract" (exn-message x)))))
   
   (contract-error-test
    'contract-error-test9