From 484be3cf024312f03e1f66550208692a6aad6c0d Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Thu, 29 Apr 2010 12:01:53 -0400
Subject: [PATCH] Add new argument to apply-contract/make-blame for the "user"
 blame label.

The new blame label gives us the location of the "use" of the value.
This blame label describes the location where we actually did the
contract wrapping, which may differ from the negative blame label.
---
 collects/racket/contract/private/base.rkt   |  8 ++++----
 collects/racket/contract/private/blame.rkt  | 11 ++++++++---
 collects/racket/contract/private/legacy.rkt |  6 ++++--
 3 files changed, 16 insertions(+), 9 deletions(-)

diff --git a/collects/racket/contract/private/base.rkt b/collects/racket/contract/private/base.rkt
index 293b66f0a1..14f71a3b04 100644
--- a/collects/racket/contract/private/base.rkt
+++ b/collects/racket/contract/private/base.rkt
@@ -27,21 +27,21 @@ improve method arity mismatch contract violation error messages?
   (syntax-case stx ()
     [(_ c v pos neg name loc)
      (syntax/loc stx
-       (apply-contract c v pos neg name loc))]
+       (apply-contract c v pos neg name loc (current-contract-region)))]
     [(_ c v pos neg)
      (syntax/loc stx
-       (apply-contract c v pos neg #f (build-source-location #f)))]
+       (apply-contract c v pos neg #f (build-source-location #f) (current-contract-region)))]
     [(_ c v pos neg src)
      (raise-syntax-error 'contract
        (string-append
         "please update contract application to new protocol "
         "(either 4 or 6 arguments)"))]))
 
-(define (apply-contract c v pos neg name loc)
+(define (apply-contract c v pos neg name loc usr)
   (let* ([c (coerce-contract 'contract c)])
     (check-source-location! 'contract loc)
     (((contract-projection c)
-      (make-blame loc name (contract-name c) pos neg #t))
+      (make-blame loc name (contract-name c) pos neg usr #t))
      v)))
 
 (define-syntax (recursive-contract stx)
diff --git a/collects/racket/contract/private/blame.rkt b/collects/racket/contract/private/blame.rkt
index a0311aa122..5e6f106965 100644
--- a/collects/racket/contract/private/blame.rkt
+++ b/collects/racket/contract/private/blame.rkt
@@ -34,7 +34,7 @@
                (hash/recur (blame-original? b))))
 
 (define-struct blame
-  [source value contract positive negative original?]
+  [source value contract positive negative user original?]
   #:property prop:equal+hash
   (list blame=? blame-hash blame-hash))
 
@@ -64,12 +64,17 @@
          [contract-message (show/write (blame-contract b))]
          [value-message (if (blame-value b)
                           (format " on ~a" (show/display (blame-value b)))
-                          "")])
-    (format "~a~a broke the contract ~a~a; ~a"
+                          "")]
+         [user-message (if (or (blame-original? b)
+                               (equal? (blame-positive b) (blame-user b)))
+                           ""
+                           (format " given to ~a" (show/display (blame-user b))))])
+    (format "~a~a broke the contract ~a~a~a; ~a"
             source-message
             positive-message
             contract-message
             value-message
+            user-message
             custom-message)))
 
 (define ((show f) v)
diff --git a/collects/racket/contract/private/legacy.rkt b/collects/racket/contract/private/legacy.rkt
index 5b80fbbe46..d912b62e41 100644
--- a/collects/racket/contract/private/legacy.rkt
+++ b/collects/racket/contract/private/legacy.rkt
@@ -21,7 +21,8 @@
                      name
                      (unpack-blame pos)
                      "<<unknown party>>"
-                     #t)
+                     #t
+                     name)
          x
          fmt
          args))
@@ -58,7 +59,8 @@
                         name
                         (unpack-blame (if original? pos neg))
                         (unpack-blame (if original? neg pos))
-                        original?)))))
+                        original? 
+                        name)))))
 
 (define (legacy-property name)
   (define-values [ prop pred get ]