diff --git a/collects/redex/tests/keyword-macros-test.rkt b/collects/redex/tests/keyword-macros-test.rkt
index 8d5f2308a7..b2109022f3 100644
--- a/collects/redex/tests/keyword-macros-test.rkt
+++ b/collects/redex/tests/keyword-macros-test.rkt
@@ -47,16 +47,19 @@
 
 (let* ([default #'3]
        [formals `((#:a ,default (,#'(-> number? string?) "#:a arg")))]
-       [parse (λ (actuals) (parse-kw-args formals actuals actuals 'test-form))])
+       [form 'test-form]
+       [parse (λ (actuals) (parse-kw-args formals actuals actuals form))])
   (test (first (parse #'())) default)
   (define arg
     (eval (first (parse #'(#:a (λ (x) 3)))) 
           (namespace-anchor->namespace test-module)))
-  (test (with-handlers ([exn:fail:contract:blame? exn-message])
-          (arg 3))
-        #rx"keyword-macros-test.*broke the contract.*on #:a arg")
-  (test (with-handlers ([exn:fail:contract:blame? exn-message])
-          (arg "NaN"))
-        #rx"test-form.*broke the contract.*on #:a arg"))
+  (test-contract-violation
+   (arg 3)
+   #:blaming "keyword-macros-test"
+   #:message "#:a arg")
+  (test-contract-violation
+   (arg "NaN")
+   #:blaming (format "~a" form)
+   #:message "#:a arg"))
 
 (print-tests-passed 'keyword-macros-test.ss)
diff --git a/collects/redex/tests/rg-test.rkt b/collects/redex/tests/rg-test.rkt
index f1f503c59f..3863750959 100644
--- a/collects/redex/tests/rg-test.rkt
+++ b/collects/redex/tests/rg-test.rkt
@@ -29,18 +29,19 @@
       (get-output-string p)
       (close-output-port p))))
 
-(define-syntax (test-contract-violation stx)
+(define-syntax (test-contract-violation/client stx)
   (syntax-case stx ()
-    [(form expr)
+    [(form expr) 
      (syntax/loc stx (form "" expr))]
     [(_ name expr)
-     (with-syntax ([expected 
-                    (syntax/loc stx
-                      (regexp (format "rg-test.*broke the contract .* ~a" name)))])
-       #'(test (raised-exn-msg 
-                exn:fail? 
-                (begin (output (λ () expr)) 'no-violation))
-               expected))]))
+     (syntax/loc stx
+       (test-contract-violation 
+        (output (λ () expr))
+        #:blaming "rg-test"
+        #:message ""
+        #:extract (match-lambda
+                    [(exn:fail:redex:test _ _ (? exn:fail:contract:blame? e) _) e]
+                    [x x])))]))
 
 (define find-base-cases/unparsed
   (compose find-base-cases parse-language))
@@ -226,7 +227,7 @@
           (parameterize ([current-namespace ns])
             (expand #'(generate-term M n))))
         #rx"generate-term: expected a identifier defined by define-language( in: M)?$")
-  (test-contract-violation (generate-term L n 1.5)))
+  (test-contract-violation/client (generate-term L n 1.5)))
 
 ;; variable-except pattern
 (let ()
@@ -770,16 +771,16 @@
                      #:print? #f)
         (counterexample 1))
   
-  (test-contract-violation
+  (test-contract-violation/client
    "#:attempts argument"
    (redex-check lang natural #t #:attempts 3.5))
-  (test-contract-violation
+  (test-contract-violation/client
    "#:retries argument"
    (redex-check lang natural #t #:retries 3.5))
-  (test-contract-violation
+  (test-contract-violation/client
    "#:attempt-size argument"
    (redex-check lang natural #t #:attempt-size -))
-  (test-contract-violation
+  (test-contract-violation/client
    "#:prepare argument"
    (redex-check lang natural #t #:prepare (λ (_) (values))))
   
@@ -926,13 +927,12 @@
           #:prepare (λ (_) (error 'fixer))
           #:print? #f))
         #rx"fixing 0")
-  (test (raised-exn-msg 
-         exn:fail:contract:blame?
-         (check-reduction-relation 
-          (reduction-relation L (--> 0 0))
-          void
-          #:prepare (λ () 0)))
-        #rx"rg-test broke the contract")
+  (test-contract-violation/client
+   "#:prepare argument" 
+   (check-reduction-relation 
+    (reduction-relation L (--> 0 0))
+    void
+    #:prepare (λ () 0)))
   
   (let ([S (reduction-relation L (--> 1 2 name) (--> 3 4))])
     (test (output (λ () (check-reduction-relation S (λ (x) #t) #:attempts 1)))
@@ -983,19 +983,19 @@
           #rx"^check-reduction-relation: unable"))
 
   (let ([R (reduction-relation L (--> any any))])
-    (test-contract-violation
+    (test-contract-violation/client
      "#:attempts argument"
      (check-reduction-relation R values #:attempts -1))
-    (test-contract-violation
+    (test-contract-violation/client
      "#:retries argument"
      (check-reduction-relation R values #:retries -1))
-    (test-contract-violation
+    (test-contract-violation/client
      "#:attempt-size argument"
      (check-reduction-relation R values #:attempt-size (λ (_) (values 1 2))))
-    (test-contract-violation
+    (test-contract-violation/client
      "#:prepare argument"
      (check-reduction-relation R values #:prepare (λ (_) (values 1 2))))
-    (test-contract-violation (check-reduction-relation R #t))))
+    (test-contract-violation/client (check-reduction-relation R #t))))
 
 ; check-metafunction
 (let ()
@@ -1109,19 +1109,19 @@
   (let ()
     (define-metafunction empty
       [(f 0) 0])
-    (test-contract-violation
+    (test-contract-violation/client
      "#:attempts argument"
      (check-metafunction f void #:attempts 3.5))
-    (test-contract-violation
+    (test-contract-violation/client
      "#:retries argument"
      (check-metafunction f void #:retries 3.5))
-    (test-contract-violation
+    (test-contract-violation/client
      "#:attempt-size argument"
      (check-metafunction f void #:attempt-size 3.5))
-    (test-contract-violation
+    (test-contract-violation/client
      "#:prepare argument"
      (check-metafunction f void #:prepare car #:print? #f))
-    (test-contract-violation (check-metafunction f (λ () #t))))
+    (test-contract-violation/client (check-metafunction f (λ () #t))))
   
   ; Extension reinterprets the LHSs of the base metafunction
   ; relative to the new language.
@@ -1254,7 +1254,7 @@
    (hash-map 
     (class-reassignments (parse-pattern '(x_1 ... x_1 ..._!_1 x_1 ..._1) lang 'top-level)) 
     (λ (_ cls) cls))
-   '(..._1 ..._1))
+   '(..._1 ..._1))    
   (test-class-reassignments
    '((3 ..._1) ..._2 (4 ..._1) ..._3)
    '((..._2 . ..._3)))
@@ -1280,4 +1280,4 @@
     (test (seed-effect-generate void)
           (seed-effect-generate random))))
 
-(print-tests-passed 'rg-test.ss)
+(print-tests-passed 'rg-test.ss)
\ No newline at end of file
diff --git a/collects/redex/tests/test-util.rkt b/collects/redex/tests/test-util.rkt
index b276c8f275..6e5fce0759 100644
--- a/collects/redex/tests/test-util.rkt
+++ b/collects/redex/tests/test-util.rkt
@@ -1,12 +1,14 @@
 #lang scheme
 
 (require "../private/matcher.ss"
+         (for-syntax syntax/parse)
          errortrace/errortrace-lib
          errortrace/errortrace-key)
 (provide test test-syn-err tests reset-count
          syn-err-test-namespace
          print-tests-passed
          equal/bindings?
+         test-contract-violation
          runtime-error-source)
 
 (define syn-err-test-namespace (make-base-namespace))
@@ -137,3 +139,23 @@
 ;; rib-lt : rib rib -> boolean
 (define (rib-lt r1 r2) (string<=? (format "~s" (bind-name r1))
                                   (format "~s" (bind-name r2))))
+
+(define-syntax (test-contract-violation stx)
+  (syntax-parse stx
+    [(_ expr
+        (~or (~once (~seq #:blaming blaming:expr))
+             (~optional (~seq #:message message:expr)
+                        #:defaults ([message #'""]))
+             (~optional (~seq #:extract extract:expr)
+                        #:defaults ([extract #'values])))
+        ...)
+     #`(test (with-handlers ([(λ (exn)
+                                (let ([exn (extract exn)])
+                                  (and (exn:fail:contract:blame? exn)
+                                       (regexp-match? 
+                                        blaming
+                                        (format "~a" (blame-positive (exn:fail:contract:blame-object exn)))))))
+                              exn-message])
+               expr
+               (gensym 'no-violation))
+             #,(syntax/loc stx (regexp message)))]))
\ No newline at end of file
diff --git a/collects/redex/tests/tl-test.rkt b/collects/redex/tests/tl-test.rkt
index 399d7561f5..1d9850291d 100644
--- a/collects/redex/tests/tl-test.rkt
+++ b/collects/redex/tests/tl-test.rkt
@@ -2233,11 +2233,11 @@
                 (λ (stx)
                   (syntax-case stx ()
                     [(_ test-form)
-                     #'(test (with-handlers ([exn:fail:contract? exn-message])
-                               (test-form (reduction-relation empty-language (--> any any))
-                                          #:equiv 1 2)
-                               "no error raised")
-                             #rx"tl-test\\.(?:.+).*broke the contract")]))])
+                     (syntax/loc stx
+                       (test-contract-violation
+                        (test-form (reduction-relation empty-language (--> any any))
+                                   #:equiv 1 2)
+                        #:blaming "tl-test"))]))])
     (test-bad-equiv-arg test-->)
     (test-bad-equiv-arg test-->>))
 
@@ -2269,15 +2269,18 @@
     
     (test (capture-output (test-results)) "2 tests failed (out of 6 total).\n")
     
-    (test (with-handlers ([exn:fail:contract? exn-message])
-            (test-->>∃ 1+ 0 (λ (x y) x)))
-          #rx"tl-test\\.(?:.+).*broke the contract.*goal expression")
-    (test (with-handlers ([exn:fail:contract? exn-message])
-            (test-->>∃ 1 0 1))
-          #rx"tl-test\\.(?:.+).*broke the contract.*reduction relation expression")
-    (test (with-handlers ([exn:fail:contract? exn-message])
-            (test-->>∃ #:steps 1.1 1+ 0 1))
-          #rx"tl-test\\.(?:.+).*broke the contract.*steps expression"))
+    (test-contract-violation
+     (test-->>∃ 1+ 0 (λ (x y) x))
+     #:blaming "tl-test"
+     #:message "goal expression")
+    (test-contract-violation
+     (test-->>∃ 1 0 1)
+     #:blaming "tl-test"
+     #:message "reduction relation expression")
+    (test-contract-violation
+     (test-->>∃ #:steps 1.1 1+ 0 1)
+     #:blaming "tl-test"
+     #:message "steps expression"))
   
   (print-tests-passed 'tl-test.ss)
   
\ No newline at end of file