From 1c4ad34b2e2051d7936be778b5cb8911c859b988 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 22 Dec 2008 13:36:32 +0000
Subject: [PATCH] add irritants to R6RS exception messages

svn: r12924
---
 collects/rnrs/base-6.ss | 26 ++++++++++++++++++++------
 1 file changed, 20 insertions(+), 6 deletions(-)

diff --git a/collects/rnrs/base-6.ss b/collects/rnrs/base-6.ss
index 4084ec3a06..1ba57a14d3 100644
--- a/collects/rnrs/base-6.ss
+++ b/collects/rnrs/base-6.ss
@@ -403,13 +403,25 @@
 (define vector-map
   (make-mapper "vector" for/list map in-vector vector-length vector->list list->vector))
 
+(define (add-irritants msg irritants)
+  (if (null? irritants)
+      msg
+      (apply
+       string-append
+       msg
+       "\n irritants:"
+       (map (lambda (s)
+              (format "\n  ~e" s))
+            irritants))))
 
 (define (r6rs:error who msg . irritants)
   (raise
    (make-exn:fail:r6rs
-    (if who
-        (format "~a: ~a" who msg)
-        msg)
+    (add-irritants
+     (if who
+         (format "~a: ~a" who msg)
+         msg)
+     irritants)
     (current-continuation-marks)
     msg
     who
@@ -418,9 +430,11 @@
 (define (assertion-violation who msg . irritants)
   (raise
    (make-exn:fail:contract:r6rs
-    (if who
-        (format "~a: ~a" who msg)
-        msg)
+    (add-irritants
+     (if who
+         (format "~a: ~a" who msg)
+         msg)
+     irritants)
     (current-continuation-marks)
     msg
     who